3:27 PM  13-SEP-93
Patch 2-3 for Staff Credentials
AQAQNQ1
AQAQNQ1 ;IHS/ANMC/LJF - MORE CREDENTIALS REPORTS; [ 09/07/93  4:11 PM ]
 ;;2.2;STAFF CREDENTIALS;**2**;01 OCT 1992
 ;
MLIC ;EP;****> prints listing of all medical licenses due to expire
 W @IOF,!!?20,"MEDICAL LICENSURES DUE TO EXPIRE",!!
 W ?5,"This report will print a listing of all medical licenses"
 W !,"that are due to expire and those already overdue."
 W !,"The report will list the providers in alphabetical order.",!!
 ;
 K DIR S DIR(0)="N0^1:12",DIR("B")=1
 S DIR("A")="Print Licenses to come due how many months from now?"
 S DIR("?",1)="Enter 0 (zero) to see only those due NOW;"
 S DIR("?",2)="Enter 1 to see those due in the coming month;"
 S DIR("?",3)="Enter 2 to see those due in the next 2 months;"
 S DIR("?",4)="And so on up to 12 months."
 S DIR("?")="All reports include those currently OVERDUE"
 D ^DIR G MEND:$D(DIRUT) S AQAQNUM=Y
 S X1=DT,X2=Y*30 D C^%DTC S AQAQDUE=X
 ;
 ;***> select type of report
TYPE W ! K DIR S DIR("A",1)="Select Sorting Order for Report:"
 S DIR("A",2)="     1.  ALPHABETICALLY (By Provider Name)"
 S DIR("A",3)="     2.  By PROVIDER CLASS"
 S DIR("A",4)="     3.  By STAFF CATEGORY"
 S DIR("A")="Select (1, 2, or 3):  ",DIR(0)="NAO^1:3" D ^DIR
 G MEND:$D(DTOUT),MEND:X="",MEND:$D(DUOUT),TYPE:Y=-1 S AQAQTYP=Y
 I AQAQTYP=1 S AQAQSRT="" G MDEV
 ;
MALL ;***> choose one or all classes or categories
 K DIR S DIR(0)="Y"
 S DIR("A")=$S(AQAQTYP=2:"Print for All Classes",1:"Print for All Categories")
 S DIR("B")="NO" D ^DIR I Y=1 S AQAQSRT="" G MDEV  ;all wards or serv
 I $D(DIRUT) G MEND  ;check for timeout,"^", or null
 ;
MCHOOSE ;***> choose which class or category to print
 I AQAQTYP=2 D  G TYPE:'$D(AQAQSRT) G MDEV
 .K DIR,AQAQSRT S DIR(0)="PO^7:EMQZ" D ^DIR
 .Q:$D(DTOUT)  Q:X=""  Q:$D(DUOUT)  Q:Y=-1
 .S AQAQSRT=$P(Y,U,2)
 E  D  G TYPE:'$D(AQAQSRT)
 .K DIR,AQAQSRT S DIR(0)="9002165,.02" D ^DIR
 .Q:$D(DTOUT)  Q:X=""  Q:$D(DUOUT)  Q:Y=-1
 .S AQAQSRT=Y(0)
 ;
MDEV S %ZIS="NPQ" D ^%ZIS G MEND:POP I '$D(IO("Q")) G MLIC1
 K IO("Q") S ZTRTN="MLIC1^AQAQNQ1",ZTDESC="LICENSES DUE TO EXPIRE"
 F AQAQI="AQAQDUE","AQAQSRT","AQAQTYP","AQAQNUM" S ZTSAVE(AQAQI)=""
 D ^%ZTLOAD D ^%ZISC K ZTSK,AQAQDUE,AQAQSRT,AQAQTYP,AQAQNUM Q
 ;
MLIC1 ;**> set variables then call FileMan print
 S L=0,DIC=9002161.2,FLDS="[AQAQ LICENSE DUE]"
 S DHD="W ?0 D MHDR^AQAQNQ1"
 I AQAQTYP=1 S BY="@PROVIDER",(TO,FR)=""
 I AQAQTYP=2 S BY="@PROVIDER",(TO,FR)=AQAQSRT
 I AQAQTYP=3 S BY="STAFF CATEGORY,@PROVIDER",(TO,FR)=AQAQSRT
 S DIS(0)="S AQAQX=$P(^AQAQML(D0,0),U,2) I AQAQX]"""",(+$G(^DIC(6,AQAQX,""I""))=0)!($G(^DIC(6,AQAQX,""I""))>DT)"  ;IHS/ORDC/LJF PATCH #2
 S IOP=ION,DIS(1)="D LASTMLIC^AQAQDUE I AQAQLAST<AQAQDUE"
 D EN1^DIP
 I '$D(ZTQUEUED) K DIR S DIR(0)="E",DIR("A")="RETURN to continue" D ^DIR W @IOF
 ;
 ;**> eoj
MEND D KILL^AQAQUTIL Q
 ;
 ;
MHDR ;**> SUBRTN for report header
 W !?8,"*****Confidential Medical Staff Data Covered by Privacy Act*****"
 W !,"Medical Licenses DUE TO EXPIRE in the next "_AQAQNUM_" months "
 S %H=$H D YX^%DTC W ?60,$P(Y,":",1,2)
 W !!,"PROVIDER NAME",?27,"STATE",?39,"EXPIRATION DATE"
 W ! S X="",$P(X,"=",80)="" W X,!!
 Q

AQQIN001
AQQIN001 ; ; 13-SEP-1993
 ;;2.2;PATCHES TO STAFF CREDENTIALS ;;SEP 13, 1993
 Q:'DIFQ(9002161.2)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DIC(9002161.2,0,"GL")
 ;;=^AQAQML(
 ;;^DIC("B","MEDICAL LICENSURE",9002161.2)
 ;;=
 ;;^DIC(9002161.2,"%D",0)
 ;;=^^2^2^2930909^^
 ;;^DIC(9002161.2,"%D",1,0)
 ;;=This file contains medical license data used by the credentials package.
 ;;^DIC(9002161.2,"%D",2,0)
 ;;=The data is stored by state.
 ;;^DD(9002161.2,0)
 ;;=FIELD^^1^5
 ;;^DD(9002161.2,0,"DDA")
 ;;=N
 ;;^DD(9002161.2,0,"DT")
 ;;=2910426
 ;;^DD(9002161.2,0,"IX","B",9002161.2,.01)
 ;;=
 ;;^DD(9002161.2,0,"IX","C",9002161.2,.02)
 ;;=
 ;;^DD(9002161.2,0,"NM","MEDICAL LICENSURE")
 ;;=
 ;;^DD(9002161.2,0,"SCR")
 ;;=I (+$G(^DIC(6,$P(^AQAQML(Y,0),U,2),"I"))=0)!($G(^DIC(6,$P(^AQAQML(Y,0),U,2),"I"))>DT)!($D(AQAQINAC))
 ;;^DD(9002161.2,.01,0)
 ;;=STATE^RP5'^DIC(5,^0;1^Q
 ;;^DD(9002161.2,.01,1,0)
 ;;=^.1
 ;;^DD(9002161.2,.01,1,1,0)
 ;;=9002161.2^B
 ;;^DD(9002161.2,.01,1,1,1)
 ;;=S ^AQAQML("B",$E(X,1,30),DA)=""
 ;;^DD(9002161.2,.01,1,1,2)
 ;;=K ^AQAQML("B",$E(X,1,30),DA)
 ;;^DD(9002161.2,.01,3)
 ;;=
 ;;^DD(9002161.2,.01,"DT")
 ;;=2910426
 ;;^DD(9002161.2,.02,0)
 ;;=PROVIDER^P9002165'^AQAQC(^0;2^Q
 ;;^DD(9002161.2,.02,1,0)
 ;;=^.1
 ;;^DD(9002161.2,.02,1,1,0)
 ;;=9002161.2^C
 ;;^DD(9002161.2,.02,1,1,1)
 ;;=S ^AQAQML("C",$E(X,1,30),DA)=""
 ;;^DD(9002161.2,.02,1,1,2)
 ;;=K ^AQAQML("C",$E(X,1,30),DA)
 ;;^DD(9002161.2,.02,1,1,"DT")
 ;;=2910426
 ;;^DD(9002161.2,.02,"DT")
 ;;=2910426
 ;;^DD(9002161.2,.03,0)
 ;;=CLASS^CJ15^^ ; ^X ^DD(9002161.2,.03,9.4) S X=$S('$D(^DIC(7,+$P(Y(9002161.2,.03,201),U,4),0)):"",1:$P(^(0),U,1)) S D0=Y(9002161.2,.03,80)
 ;;^DD(9002161.2,.03,9)
 ;;=^
 ;;^DD(9002161.2,.03,9.01)
 ;;=6^2;9002165^.01;9002161.2^.02
 ;;^DD(9002161.2,.03,9.1)
 ;;=PROVIDER:NAME OF PROVIDER:CLASS
 ;;^DD(9002161.2,.03,9.2)
 ;;=S Y(9002161.2,.03,80)=$S($D(D0):D0,1:""),Y(9002161.2,.03,1)=$S($D(^AQAQML(D0,0)):^(0),1:""),D0=$P(Y(9002161.2,.03,1),U,2) S:'$D(^AQAQC(+D0,0)) D0=-1
 ;;^DD(9002161.2,.03,9.3)
 ;;=X ^DD(9002161.2,.03,9.2) S Y(9002161.2,.03,180)=$S($D(D0):D0,1:""),Y(9002161.2,.03,101)=$S($D(^AQAQC(D0,0)):^(0),1:"")
 ;;^DD(9002161.2,.03,9.4)
 ;;=X ^DD(9002161.2,.03,9.3) S D0=$P(Y(9002161.2,.03,101),U,1) S:'$D(^DIC(6,+D0,0)) D0=-1 S Y(9002161.2,.03,201)=$S($D(^DIC(6,D0,0)):^(0),1:"")
 ;;^DD(9002161.2,.04,0)
 ;;=STAFF CATEGORY^CJ15^^ ; ^X ^DD(9002161.2,.04,9.3) S X=$P($P(Y(9002161.2,.04,102),$C(59)_$P(Y(9002161.2,.04,101),U,2)_":",2),$C(59),1) S D0=Y(9002161.2,.04,80)
 ;;^DD(9002161.2,.04,9)
 ;;=^
 ;;^DD(9002161.2,.04,9.01)
 ;;=9002165^.02;9002161.2^.02
 ;;^DD(9002161.2,.04,9.1)
 ;;=PROVIDER:STAFF CATEGORY
 ;;^DD(9002161.2,.04,9.2)
 ;;=S Y(9002161.2,.04,80)=$S($D(D0):D0,1:""),Y(9002161.2,.04,1)=$S($D(^AQAQML(D0,0)):^(0),1:""),D0=$P(Y(9002161.2,.04,1),U,2) S:'$D(^AQAQC(+D0,0)) D0=-1
 ;;^DD(9002161.2,.04,9.3)
 ;;=X ^DD(9002161.2,.04,9.2) S Y(9002161.2,.04,102)=$C(59)_$S($D(^DD(9002165,.02,0)):$P(^(0),U,3),1:""),Y(9002161.2,.04,101)=$S($D(^AQAQC(D0,0)):^(0),1:"")
 ;;^DD(9002161.2,1,0)
 ;;=MED LICENSE EXPIRATION DATE^9002161.21D^^1;0
 ;;^DD(9002161.21,0)
 ;;=MED LICENSE EXPIRATION DATE SUB-FIELD^^.03^3
 ;;^DD(9002161.21,0,"DT")
 ;;=2910426
 ;;^DD(9002161.21,0,"IX","B",9002161.21,.01)
 ;;=
 ;;^DD(9002161.21,0,"NM","MED LICENSE EXPIRATION DATE")
 ;;=
 ;;^DD(9002161.21,0,"UP")
 ;;=9002161.2
 ;;^DD(9002161.21,.01,0)
 ;;=MED LICENSE EXPIRATION DATE^D^^0;1^S %DT="E" D ^%DT S X=Y K:Y<1 X
 ;;^DD(9002161.21,.01,1,0)
 ;;=^.1
 ;;^DD(9002161.21,.01,1,1,0)
 ;;=9002161.21^B
 ;;^DD(9002161.21,.01,1,1,1)
 ;;=S ^AQAQML(DA(1),1,"B",$E(X,1,30),DA)=""
 ;;^DD(9002161.21,.01,1,1,2)
 ;;=K ^AQAQML(DA(1),1,"B",$E(X,1,30),DA)
 ;;^DD(9002161.21,.01,"DT")
 ;;=2910426

AQQIN002
AQQIN002 ; ; 13-SEP-1993
 ;;2.2;PATCHES TO STAFF CREDENTIALS ;;SEP 13, 1993
 Q:'DIFQ(9002161.2)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(9002161.21,.02,0)
 ;;=DATE MEDICAL LICENSE VERIFIED^D^^0;2^S %DT="E" D ^%DT S X=Y K:Y<1 X
 ;;^DD(9002161.21,.02,4)
 ;;=D MLHELP^AQAQNQ
 ;;^DD(9002161.21,.02,"DT")
 ;;=2910426
 ;;^DD(9002161.21,.03,0)
 ;;=LICENSE OVERDUE^CJ12^^ ; ^X ^DD(9002161.21,.03,9.3) S X=$S(Y(9002161.21,.03,3):Y(9002161.21,.03,4),Y(9002161.21,.03,5):X)
 ;;^DD(9002161.21,.03,9)
 ;;=^
 ;;^DD(9002161.21,.03,9.01)
 ;;=9002161.21^.01
 ;;^DD(9002161.21,.03,9.1)
 ;;=$S(MED LICENSE EXPIRATION DATE-TODAY>0:"OK",1:"**OVERDUE**")
 ;;^DD(9002161.21,.03,9.2)
 ;;=S Y(9002161.21,.03,1)=$S($D(^AQAQML(D0,1,D1,0)):^(0),1:"") S X=$P(Y(9002161.21,.03,1),U,1),Y(9002161.21,.03,2)=X,X=DT S Y=X,X=Y(9002161.21,.03,2),X=X S X=X,X1=X,X2=Y,X="" D:X2 ^%DTC:X1 S X=X
 ;;^DD(9002161.21,.03,9.3)
 ;;=X ^DD(9002161.21,.03,9.2) S X=X>0,Y(9002161.21,.03,3)=X S X="OK",Y(9002161.21,.03,4)=X S X=1,Y(9002161.21,.03,5)=X S X="**OVERDUE**"
 ;;^DD(9002161.21,.03,9.4)
 ;;=X ^DD(9002161.21,.03,9.3) S Y(9002161.21,.03,6)=X S X=$P(Y(9002161.21,.03,1),U,1) S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) S X=X_"  **OVERDUE**"
 ;;^DD(9002161.21,.03,"DT")
 ;;=2910906

AQQIN003
AQQIN003 ; ; 13-SEP-1993
 ;;2.2;PATCHES TO STAFF CREDENTIALS ;;SEP 13, 1993
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"PKG",232,0)
 ;;=PATCHES TO STAFF CREDENTIALS ^AQQ^CONTAINS ALL PATCHES FOR STAFF CREDENTIALS
 ;;^UTILITY(U,$J,"PKG",232,4,0)
 ;;=^9.44PA^1^1
 ;;^UTILITY(U,$J,"PKG",232,4,1,0)
 ;;=9002161.2
 ;;^UTILITY(U,$J,"PKG",232,4,1,222)
 ;;=y^n^^n^^^n
 ;;^UTILITY(U,$J,"PKG",232,4,"B",9002161.2,1)
 ;;=
 ;;^UTILITY(U,$J,"PKG",232,5)
 ;;=OKCRDC
 ;;^UTILITY(U,$J,"PKG",232,22,0)
 ;;=^9.49I^1^1
 ;;^UTILITY(U,$J,"PKG",232,22,1,0)
 ;;=2.2^2930913
 ;;^UTILITY(U,$J,"PKG",232,22,"B",2.2,1)
 ;;=
 ;;^UTILITY(U,$J,"PKG",232,"DEV")
 ;;=BJ HELDENBRAND/OKCRDC
 ;;^UTILITY(U,$J,"SBF",9002161.2,9002161.2)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9002161.2,9002161.21)
 ;;=

AQQINIT
AQQINIT ; ; 13-SEP-1993
 ;;2.2;PATCHES TO STAFF CREDENTIALS ;;SEP 13, 1993
 ;
 K DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT
 S U="^",DIFQ=0,DIFROM="2.2" W !,"This version (#2.2) of 'AQQINIT' was created on 13-SEP-1993"
 W !?9,"(at ORDC, by VA FileMan V.19.0)",!
 I $D(^DD("VERSION")),^("VERSION")'<19 G GO:$N(^("VERSION","19.0"))<0 W !,"BUT I'M OBSOLETE!!" G Q
 W !,"FIRST, I'LL FRESHEN UP YOUR VA FILEMAN...." D N^DINIT
 I ^DD("VERSION")<19 W !,"BUT I NEED VERSION 19 OF THE VA FILEMAN!" G Q
GO ;
EN ; ENTER HERE TO BYPASS THE PRE-INIT PROGRAM
 S DIFQ=0 K DIRUT,DTOUT,DUOUT
 F DIFRIR=1:1:1 S DIFRRTN="^AQQINIT"_$E("5",DIFRIR) D @DIFRRTN
 W:1 !,"I AM GOING TO SET UP THE FOLLOWING FILES:" F I=1:2:2 S DIF(I)=^UTILITY("DIF",$J,I) D 1 G Q:DIFQ!$D(DIRUT) K DIF(I)
 S DIFROM="2.2" D PKG:'$D(DIFROM(0)),^AQQINIT1 G Q:'$D(DIFQ) S DIK(0)="AB"
 F DIF=1:2:2 S %=^UTILITY("DIF",$J,DIF),DIK=$P(%,";",5),N=$P(%,";",3),D=$P(%,";",4)_U_N D D K DIFQ(N)
 K DIFQR D ^AQQINIT2,^AQQINIT3
 L  S DUZ=DIDUZ W:1 !,*7,"OK, I'M DONE.",!,"NO"_$P("TE THAT FILE",U,DSEC)_" SECURITY-CODE PROTECTION HAS BEEN MADE"
 I DIFROM F DIF=1:2:2 S %=^UTILITY("DIF",$J,DIF),N=+$P(%,";",3) I N,$P(%,";",8)="y" S ^DD(N,0,"VR")=DIFROM
 I DIFROM(0)>0 F %="PRE","INI","INIT" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%)
 I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN
 S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),"VERSION")=DIFROM G Q^DIFROM0
D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_"0)")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U)
 S DIFQR=DIFQR(+N) I ^DD("VERSION")>17.5,$D(^DD(+N,0,"DIK"))#2 S X=^("DIK"),Y=+N,DMAX=^DD("ROU") D EN^DIKZ
 I DIFQR D IXALL^DIK:$O(@(DIK_"0)")) W "."
 Q
R G REP^AQQINIT2
 ;
1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5)
 W !!?3,N,?13,DIF,$P("  (Partial Definition)",U,$P(DIF(I),";",6)),$P("  (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"")
 I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S
 I $L($P(Z,DIF)) W *7,!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ  G S:$D(DIFKEP(N)),1
 S DIFQ(N)=$P(DIF(I),";",7)'="n"
 I $L(Z) W *7,!,"Note:  You already have the '",$P(Z,U),"' File." S DIFQ(0)=1
 S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S
 I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y
S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT)
 I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q
 S %=$P(DIF(I),";",14)="o" W !,*7,"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1
 Q
Q W *7,!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0
 ;
PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC
 Q
 ;
IXF ;;PATCHES TO STAFF CREDENTIALS ^AQQ;28
ERX W *7,!!,"This INIT was built as a Network Mail Message and can ONLY be installed",!,"within the Mail system!!" G Q

AQQINIT1
AQQINIT1 ; ; 13-SEP-1993
 ;;2.2;PATCHES TO STAFF CREDENTIALS ;;SEP 13, 1993
 ; LOADS AND INDEXES DD'S
 ;
 K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U="^",DSEC=1
 S NO=$P("I 0^I $D(@X)#2,X[U",U,%) I %<1 K DIFQ Q
ASK I %=1,$D(DIFQ(0)) W !,"SHALL I WRITE OVER FILE SECURITY CODES" S %=2 D YN^DICN S DSEC=%=1 I %<1 K DIFQ Q
 Q:'$D(DIFQ)  S %=2 W !!,"ARE YOU SURE EVERYTHING'S OK" D YN^DICN I %-1 K DIFQ Q
 I $D(DIFKEP) F DIDIU=0:0 S DIDIU=$N(DIFKEP(DIDIU)) Q:DIDIU'>0  S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2
 D DT^DICRW K ^UTILITY(U,$J),^UTILITY("DIK",$J) D WAIT^DICD
 S DN="^AQQIN" F R=1001:1:1003 D ROU W "."
 F  S D=$O(^UTILITY(U,$J,"SBF","")) Q:D'>0  K:'DIFQ(D) ^(D) S D=$O(^(D,"")) I D>0  K ^(D) D IX
DATA W "." S (D,DDF(1),DDT(0))=$N(^UTILITY(U,$J,0)) Q:D'>0
 I DIFQR(D) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=DIFQR(D)'=2 F D0=0:0 S D0=$N(^UTILITY(U,$J,DDF(1),D0)) Q:'$D(^(D0,0))  S Z=^(0) D I^DITR
 K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA
 ;
W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0))
 S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W
 S:%=2 DIFQ(X)=0 K:%<0 DIFQ
 Q
 ;
OPT ;OPTION
RTN ;ROUTINE DOCUMENTATION NOTE
FUN ;FUNCTION
BUL ;BULLETIN
KEY ;SECURITY KEY
HEL ;HELP FRAME
DIP ;PRINT TEMPLATE
DIE ;INPUT TEMPLATE
DIB ;SORT TEMPLATE
DIS ;SCREEN TEMPLATE
 ;
SBF ;FILE AND SUB FILE NUMBERS
IX W "." S DIK="A" F %=0:0 S DIK=$N(^DD(D,DIK)) Q:DIK<0  K ^(DIK)
 S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK
 I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK
 Q
ROU I R<2000 D @(DN_$E(R,2,4)) Q
 I R=2000 S R=2028
 S %C=R#52+65,%B=R-2028\52+65 S:%B>90 %B=%B+6 S:%C>90 %C=%C+6
 D @(DN_$C(48,%B,%C))
 Q
MSG ;
 I $P(^XMB(3.9,XMZ,0),U,7)'="X" Q
 S X=$S($D(^XMB(3.9,XMZ,2,XCN,0)):^(0),1:"") Q:X=""
M0 D M1 Q:$P(X,"$END MESSAGE")=""  D SAVE,NT G M0
NT S XCN=$O(^XMB(3.9,XMZ,2,XCN)) Q:XCN'?1.N  S X=^(XCN,0) Q
SAVE D NT Q:$E(X)="$"  S Y=X D NT Q:$E(X)="$"
 I $A(X)=126 S A0=X D NT S X=A0_$E(X,2,999) K A0
 S:% @Y=$E(X,2,999) G SAVE
 Q
M1 S Y=$E(X,2,4),%=0 I Y="DDD" S D=+$P(X,"(#",2),%=DIFQ(D) Q:D  S:$P(X,"(#",2)["FILE SECURITY" %=DSEC Q
 Q:Y="END"
 I Y="DTA" S %=DIFQR(D) Q
 I (Y="OR ")!(Y="PKG") S %=1 Q
 I $T(@Y)]"" S %=1 Q
 Q

AQQINIT2
AQQINIT2 ; ; 13-SEP-1993
 ;;2.2;PATCHES TO STAFF CREDENTIALS ;;SEP 13, 1993
 ;
 ;
 K ^UTILITY("DIFROM",$J),DIC S DIDUZ=0 S:$D(DUZ)#2 DIDUZ=DUZ S DUZ=.5
 I $D(^DIC(9.2,0))#2,^(0)?1"HEL".E S (DIC,DLAYGO)=9.2,N="HEL",DIC(0)="LX" G ADD
 Q
 ;
ADD F R=0:0 S R=$N(^UTILITY(U,$J,N,R)) Q:R<0  S X=$P(^(R,0),U,1) W "." K DA D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ^UTILITY("DIFROM",$J,N,X)=+Y K ^DIC(9.2,+Y,1),^(2),^(3),^(10) S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y D %XY^%RCR
 S DIK=DIC
HELP S R=$N(^UTILITY("DIFROM",$J,N,R)) Q:R<0  W !,"'"_R_"' Help Frame filed." S DA=^(R)
 F X=0:0 S X=$O(^DIC(9.2,DA,2,X)) Q:'X  S I=$S($D(^(X,0)):^(0),1:0),Y=$P(I,U,2) S:Y]"" Y=$N(^DIC(9.2,"B",Y,0)) S ^(0)=$P(^DIC(9.2,DA,2,X,0),U,1)_U_$S(Y>0:Y,1:"")_U_$P(^(0),U,3,99)
 S I=0 F X=0:0 S X=$O(^DIC(9.2,DA,10,X)) Q:'X  I $D(^(X,0)) S Y=$P(^(0),U),Y=$S(Y]"":$O(^MAG("B",Y,0)),1:0) S:Y $P(^DIC(9.2,DA,10,X,0),U)=Y,I=I+1,%=X I 'Y K ^DIC(9.2,DA,10,X,0)
 I I S $P(^DIC(9.2,DA,10,0),U,3,4)=%_U_I
IX D IX1^DIK G HELP
 ;
U I $D(DIRUT) S DIFQ=1
 W ! Q
REP S DIR(0)="Y",DIR("A")="Shall I change the NAME of the file to "_DIF
 S DIR("??")="^D REP^DIFROMH1",DIR("B")="NO" D ^DIR G U:$D(DIRUT)
 I Y S DIE=1,DIFQ=0,DA=N,DR=".01////"_DIF D ^DIE Q
 S DIR("A")="Shall I replace your file with mine"
 S DIR("??")="^D AG^DIFROMH1" D ^DIR G U:$D(DIRUT)!'Y
 S DIU(0)="E",DIR("A")="Do you want to keep the Data"
 S DIR("??")="^D CHG^DIFROMH1" D ^DIR G U:$D(DIRUT)
 S:'Y DIU(0)=DIU(0)_"D"
 S DIR("A")="Do you want to keep the Templates"
 S DIR("??")="^D TEMP^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"T"
 S DIFQ(N)=1,DIFKEP(N)=DIU(0) W !?15," (",DIF,") " Q

AQQINIT3
AQQINIT3 ; ; 13-SEP-1993
 ;;2.2;PATCHES TO STAFF CREDENTIALS ;;SEP 13, 1993
 ;
 ;
 K ^UTILITY("DIFROM",$J) S DIC(0)="LX",(DIC,DLAYGO)=3.6,N="BUL" D ADD:$D(^XMB(3.6,0))
 S X=0 F R=0:0 S X=$N(^UTILITY("DIFROM",$J,N,X)) Q:X<0  W !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins."
 I $D(^DIC(9.4,0))#2,^(0)?1"PACK".E S N="PKG",(DIC,DLAYGO)=9.4 D ADD
 G NP:'$D(DA) S %=+$O(^DIC(9.4,DA,22,"B",DIFROM,0)) I $D(^DIC(9.4,DA,22,%,0)) S $P(^(0),U,3)=DT
 I $D(^DIC(9.4,DA,0))#2 S %=$P(^(0),U,4) I %]"" S %=$N(^DIC(9.2,"B",%,0)) S:%]"" $P(^DIC(9.4,DA,0),U,4)=%
OR I $D(^ORD(100.99))&$O(^UTILITY(U,$J,"OR","")) D EN^AQQINIT4
NP K DIC,^UTILITY("DIFROM",$J) S DIC(0)="LX" I $D(^DIC(19,0))#2,^(0)?1"OPTION".E S (DIC,DLAYGO)=19,N="OPT" D ADD,OP
 I $D(^DIC(19.1,0))#2,($P(^(0),U)?1"SECUR".E)!($P(^(0),U)="KEY") S (DIC,DLAYGO)=19.1,N="KEY" D ADD K ^UTILITY("DIFROM",$J)
 I $D(^DIC(9.8,0))#2,^(0)?1"ROUTINE^".E S (DIC,DLAYGO)=9.8,N="RTN" D ADD
 S DIC=.5,DLAYGO=0,N="FUN" D ADD
 S DIC("S")="I $P(^(0),U,4)=DIFL" F N="DIPT","DIBT","DIE" S DIC=U_N_"(" D ADD
 K DIC("S") S N="DIST(.404,",DIC=U_N,DLAYGO=.404 D ADD
 S DIC("S")="I $P(^(0),U,8)=DIFL",N="DIST(.403,",DIC=U_N,DLAYGO=.403 D ADD
 K ^UTILITY(U,$J),DIC,DLAYGO F DIFR="DIE","DIPT" D DIEZ
 K ^UTILITY("DIFROM",$J) Q
DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII
 E  S DISYS=^DD("OS")
 Q:'$D(^DD("OS",DISYS,"ZS"))
 S DIFR1=""
DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1=""
 F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2  S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z")
 G DZ1
 ;
OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q
 W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP
 I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=%
 S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0))
 S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0
 S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C")
 F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X  S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X),^DIC(19,"AD",+I,DA,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X
 S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP
 ;
ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R=""  S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A
Q Q
A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'%  S %(%)=$G(^(%,0))
 K:N'="KEY"&(N'="OPT") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^")
 I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'%  S @(DIC_"+Y,2,%,0)")=%(%)
 I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_" template "_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" not on your system!"
 I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1)
 I N="DIST(.403," D BLK
 S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR
 D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT
 Q
BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J  I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1
 K A0,A1,A2,J,L Q
B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L  S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0
 S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0=""  K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0
 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L  S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1
 S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK")
 Q

AQQINIT4
AQQINIT4 ; ; 13-SEP-1993
 ;;2.2;PATCHES TO STAFF CREDENTIALS ;;SEP 13, 1993
 ;
 ;
EN S DA(1)=1,DIK="^ORD(100.99,1,5," I $D(^ORD(100.99,1,5,DA)) D ^DIK
 S %X="^UTILITY(U,$J,""OR"","_$O(^UTILITY(U,$J,"OR",""))_",",%Y=DIK_DA_","
 S:'$D(^ORD(100.99,1,5,0)) ^(0)="^100.995P^^" S $P(^(0),U,3,4)=DA_U_($P(^(0),U,4)+1)
 D %XY^%RCR S $P(^ORD(100.99,1,5,DA,0),U)=DA,%=$P(^(0),U,4)
 I %]"" S %=$N(^ORD(100.98,"B",%,0)) I %>0 S $P(^ORD(100.99,1,5,DA,0),U,4)=%
 D OR
 S DA(1)=1 D IX1^DIK
 Q
OR S (N,I)=0,X=""
 F  S N=$O(^ORD(100.99,1,5,DA,1,N)) Q:'N  S X=$P(^(N,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,0)=% S X=N,I=I+1,(R,J)=0,Y="" D OR1
 S:I $P(^ORD(100.99,1,5,DA,1,0),U,3,4)=X_U_I S (N,I)=0,X=""
 F  S N=$O(^ORD(100.99,1,5,DA,5,N)) Q:'N  S X=$P(^(N,0),U,3) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% $P(^ORD(100.99,1,5,DA,5,N,0),U,3)=% S X=N,I=I+1
 S:I $P(^ORD(100.99,1,5,DA,5,0),U,3,4)=X_U_I K N,R,X,Y,I,J
 Q
OR1 N X F  S R=$O(^ORD(100.99,1,5,DA,1,N,1,R)) Q:'R  S X=$P(^(R,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,1,R,0)=% S Y=R,J=J+1
 S:J $P(^ORD(100.99,1,5,DA,1,N,1,0),U,3,4)=Y_U_J
 Q
ADDP N I,J,N,R,DA,DLAYGO S %=""
 S DIC="^ORD(101,",DIC(0)="LX",DLAYGO=101 D FILE^DICN K DIC Q:Y=-1  S %=+Y Q

AQQINIT5
AQQINIT5 ; ; 13-SEP-1993
 ;;2.2;PATCHES TO STAFF CREDENTIALS ;;SEP 13, 1993
 K ^UTILITY("DIF",$J) S DIFRDIFI=1 F I=1:1:2 S ^UTILITY("DIF",$J,DIFRDIFI)=$T(IXF+I),DIFRDIFI=DIFRDIFI+1
 Q
IXF ;;PATCHES TO STAFF CREDENTIALS ^AQQ
 ;;9002161.2sP;MEDICAL LICENSURE;^AQAQML(;0;y;n;;n;;;n
 ;;