- PSOLLU4 ;BIR/EJW - CHANGE CONTROL CODES ;05/23/2004
- ;;7.0;OUTPATIENT PHARMACY;**161**;DEC 1997
- ;
- ;Read-only reference to %ZIS(2 supported by DBIA 3435
- ;Reference to %ZIS(2 supported by DBIA 3884
- ;
- N IO,IOST
- S %ZIS="MN"
- IO D ^%ZIS
- I '$G(IOST(0)) W "No terminal type available." Q
- I '$D(DUZ(0)) W "No DUZ defined." Q
- I DUZ(0)'="@" W "FileMan access must be @." Q
- I '$D(^%ZIS(2,IOST(0),55,"B","LL")) W "No CONTROL CODES defined." Q
- W !!,"You will be copying the CONTROL CODES to device: ",IO K DIR W ! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Are you sure" D ^DIR K DIR I Y'=1 G IO
- W !,"Copying..."
- S AB="PFI",NAME="PATIENT FILL INITIALIZATION",CODE="S PSOFONT=""F10"",PSOX=1210,PSOY=710,PSOYI=45,PSOHFONT=""F12"",PSOBYI=100" D FILE
- S AB="PFDW",NAME="PHARMACY FILL DOCUMENT WARNING",CODE="S PSOY=1258,PSOX=660,PSOYI=30,PSOFONT=""F8"",PSOYM=1329" D FILE
- S AB="MLI",NAME="MAILING LABEL INITIALIZATION",CODE="S PSOFONT=""F10"",PSOX=1680,PSOY=175,PSOYI=50" D FILE
- S AB="RMI",NAME="RETURN MAIL INITIALIZATION",CODE="S PSOHFONT=""F8"",PSOFONT=""F10"",PSOX=1680,PSOY=35,PSORYI=40,PSOHYI=40,PSOTFONT=""F8"",PSOTY=550" D FILE
- D CLEAN
- Q
- FILE K DIC,DIE S DIC(0)="L",DA(1)=IOST(0),X=AB,DIC="^%ZIS(2,"_DA(1)_",55," D FILE^DICN
- K DA,DR,DIE S DIE=DIC,DA=+Y,DA(1)=IOST(0)
- S DR=".01////"_AB_";1////"_NAME_";2////"_CODE D ^DIE
- Q
- ;
- CLEAN ; REMOVE EXACT DUPLICATE CONTROL CODES RESULTING WHEN CHANGE CONTROL CODES ROUTINES ARE RUN MORE THAN ONCE
- I '$G(DT) S DT=$$DT^XLFDT
- I '$D(^XTMP("PSOLLU4")) S X1=DT,X2=+90 D C^%DTC S ^XTMP("PSOLLU4",0)=$G(X)_"^"_DT
- I '$D(IOST(0)) Q
- M ^XTMP("PSOLLU4",$J,IOST(0))=^%ZIS(2,IOST(0)) ; SAVE COPY OF SETTINGS BEFORE CLEAN-UP
- S CODE="" F S CODE=$O(^%ZIS(2,IOST(0),55,"B",CODE)) Q:CODE="" S SEQ=0 F S SEQ=$O(^%ZIS(2,IOST(0),55,"B",CODE,SEQ)) Q:'SEQ D
- .I '$D(^%ZIS(2,IOST(0),55,SEQ)) K ^%ZIS(2,IOST(0),55,"B",CODE,SEQ) Q
- .S SEQ1=$O(^%ZIS(2,IOST(0),55,"B",CODE,SEQ)) I SEQ1="" Q
- .S X0=$G(^%ZIS(2,IOST(0),55,SEQ,0)),X1=$G(^(1))
- .S Z0=$G(^%ZIS(2,IOST(0),55,SEQ1,0)),Z1=$G(^(1))
- .I X0'="",X1'="" D
- ..I X0=Z0,X1=Z1 K ^%ZIS(2,IOST(0),55,"B",CODE,SEQ),^%ZIS(2,IOST(0),55,SEQ)
- Q
- ;
- PSOLLU4 ;BIR/EJW - CHANGE CONTROL CODES ;05/23/2004
- +1 ;;7.0;OUTPATIENT PHARMACY;**161**;DEC 1997
- +2 ;
- +3 ;Read-only reference to %ZIS(2 supported by DBIA 3435
- +4 ;Reference to %ZIS(2 supported by DBIA 3884
- +5 ;
- +6 NEW IO,IOST
- +7 SET %ZIS="MN"
- IO DO ^%ZIS
- +1 IF '$GET(IOST(0))
- WRITE "No terminal type available."
- QUIT
- +2 IF '$DATA(DUZ(0))
- WRITE "No DUZ defined."
- QUIT
- +3 IF DUZ(0)'="@"
- WRITE "FileMan access must be @."
- QUIT
- +4 IF '$DATA(^%ZIS(2,IOST(0),55,"B","LL"))
- WRITE "No CONTROL CODES defined."
- QUIT
- +5 WRITE !!,"You will be copying the CONTROL CODES to device: ",IO
- KILL DIR
- WRITE !
- SET DIR(0)="Y"
- SET DIR("B")="YES"
- SET DIR("A")="Are you sure"
- DO ^DIR
- KILL DIR
- IF Y'=1
- GOTO IO
- +6 WRITE !,"Copying..."
- +7 SET AB="PFI"
- SET NAME="PATIENT FILL INITIALIZATION"
- SET CODE="S PSOFONT=""F10"",PSOX=1210,PSOY=710,PSOYI=45,PSOHFONT=""F12"",PSOBYI=100"
- DO FILE
- +8 SET AB="PFDW"
- SET NAME="PHARMACY FILL DOCUMENT WARNING"
- SET CODE="S PSOY=1258,PSOX=660,PSOYI=30,PSOFONT=""F8"",PSOYM=1329"
- DO FILE
- +9 SET AB="MLI"
- SET NAME="MAILING LABEL INITIALIZATION"
- SET CODE="S PSOFONT=""F10"",PSOX=1680,PSOY=175,PSOYI=50"
- DO FILE
- +10 SET AB="RMI"
- SET NAME="RETURN MAIL INITIALIZATION"
- SET CODE="S PSOHFONT=""F8"",PSOFONT=""F10"",PSOX=1680,PSOY=35,PSORYI=40,PSOHYI=40,PSOTFONT=""F8"",PSOTY=550"
- DO FILE
- +11 DO CLEAN
- +12 QUIT
- FILE KILL DIC,DIE
- SET DIC(0)="L"
- SET DA(1)=IOST(0)
- SET X=AB
- SET DIC="^%ZIS(2,"_DA(1)_",55,"
- DO FILE^DICN
- +1 KILL DA,DR,DIE
- SET DIE=DIC
- SET DA=+Y
- SET DA(1)=IOST(0)
- +2 SET DR=".01////"_AB_";1////"_NAME_";2////"_CODE
- DO ^DIE
- +3 QUIT
- +4 ;
- CLEAN ; REMOVE EXACT DUPLICATE CONTROL CODES RESULTING WHEN CHANGE CONTROL CODES ROUTINES ARE RUN MORE THAN ONCE
- +1 IF '$GET(DT)
- SET DT=$$DT^XLFDT
- +2 IF '$DATA(^XTMP("PSOLLU4"))
- SET X1=DT
- SET X2=+90
- DO C^%DTC
- SET ^XTMP("PSOLLU4",0)=$GET(X)_"^"_DT
- +3 IF '$DATA(IOST(0))
- QUIT
- +4 ; SAVE COPY OF SETTINGS BEFORE CLEAN-UP
- MERGE ^XTMP("PSOLLU4",$JOB,IOST(0))=^%ZIS(2,IOST(0))
- +5 SET CODE=""
- FOR
- SET CODE=$ORDER(^%ZIS(2,IOST(0),55,"B",CODE))
- IF CODE=""
- QUIT
- SET SEQ=0
- FOR
- SET SEQ=$ORDER(^%ZIS(2,IOST(0),55,"B",CODE,SEQ))
- IF 'SEQ
- QUIT
- Begin DoDot:1
- +6 IF '$DATA(^%ZIS(2,IOST(0),55,SEQ))
- KILL ^%ZIS(2,IOST(0),55,"B",CODE,SEQ)
- QUIT
- +7 SET SEQ1=$ORDER(^%ZIS(2,IOST(0),55,"B",CODE,SEQ))
- IF SEQ1=""
- QUIT
- +8 SET X0=$GET(^%ZIS(2,IOST(0),55,SEQ,0))
- SET X1=$GET(^(1))
- +9 SET Z0=$GET(^%ZIS(2,IOST(0),55,SEQ1,0))
- SET Z1=$GET(^(1))
- +10 IF X0'=""
- IF X1'=""
- Begin DoDot:2
- +11 IF X0=Z0
- IF X1=Z1
- KILL ^%ZIS(2,IOST(0),55,"B",CODE,SEQ),^%ZIS(2,IOST(0),55,SEQ)
- End DoDot:2
- End DoDot:1
- +12 QUIT
- +13 ;
