PSIVLBRP.m

PSIVLBRP ;BIR/MV - REPRINT LABELS FOR AN ORDER ;15 May 2001  3:29 PM

 ;;5.0; INPATIENT MEDICATIONS ;**58,97**;16 DEC 97

 ;

 ; Reference to ^PS(55 is supported by DBIA 2191.

 ;

EN(PSJIDLST) ;

 I '$D(PSJIDLST) W !,"No labels are available" D PAUSE^VALM1 Q

 NEW DIR,PSIVCTD

 S PSIVCT=1

 W !!,"Count as daily usage" S %=1 D YN^DICN Q:%=-1  S PSIVCTD=$S(%=1:1,1:0)

 I PSIVCTD=1 K PSIVCT

 S PSJY=$$PROMPT()

 Q:PSJY=""

 D PRT

 Q

PROMPT() ;

 W !

 S DIR(0)="LOA^1:"_PSJIDLST,DIR("A")="Select from 1 - "_PSJIDLST_" or <RETURN> to select by BCMA ID: " D ^DIR

 K DIR

 S PSJY=Y

 I PSJY="" S DIR(0)="FOA^1:50^S X=$$UP^XLFSTR(X) K:'$D(PSJIDLST(X)) X",DIR("A")="Enter a BCMA ID: " D ^DIR S PSJY=$$UP^XLFSTR(Y)

 K DIR

 W !!

 Q PSJY

DEQIA ;

 S PSIVNOL=0

 F PSJSEL=1:1 S PSJSEL1=$P(PSJY,",",PSJSEL) Q:PSJSEL1=""  S PSIVNOL=PSIVNOL+1

 F PSJSEL=1:1 S PSJSEL1=$P(PSJY,",",PSJSEL) Q:PSJSEL1=""  D

 . S:'PSIVCTD PSIVCT=1

 . S PSJID=$G(PSJIDLST(PSJSEL1)) Q:PSJID=""  D REPRT(PSJID)

 K PSJRPHD

 Q

REPRT(PSJID) ;

 S PSJNEWID=$$BCMA^PSIVBCID(DFN,ON,$D(PSIVCT),$G(PSIV1),$G(PSIV2),$G(PSIVNOL))

 I PSJNEWID="" W !,"Can't get a new BCMA ID.  Try again" Q

 S PSJIDNO=$P(PSJID,"V",2)

 S PSIVBAG=$P($G(^PS(55,DFN,"IVBCMA",PSJIDNO,0)),U,8)

 N DA,DR,DIE,DIC

 ;S DIC(0)="L",DA=Y,DA(1)=DFN,X=PSJNEWID,DIC="^PS(55,"_DA(1)_",""IVBCMA""," D FILE^DICN

 K DA,DR,DIE S DIE="^PS(55,"_DFN_",""IVBCMA"",",DA=$P(PSJNEWID,"V",2),DA(1)=DFN D NOW^%DTC

 ;S DR=".02////"_+ON_";3////"_PSIVCTD_";4////"_$E(%,1,12)_";6////"_PSIVBAG D ^DIE

 S DR="6////"_PSIVBAG D ^DIE

 K DA,DR,DIE,DIC

 S PSJNEWID=$P(PSJNEWID,"V",2)

 F PSJAD=0:0 S PSJAD=$O(^PS(55,DFN,"IVBCMA",PSJIDNO,"AD",PSJAD)) Q:'PSJAD  D

 . S PSJADX=$G(^PS(55,DFN,"IVBCMA",PSJIDNO,"AD",PSJAD,0))

 . D UP2^PSIVBCID(DFN,PSJNEWID,PSJAD,PSJADX)

 F PSJSOL=0:0 S PSJSOL=$O(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSJSOL)) Q:'PSJSOL  D

 . S PSJSOLX=$G(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSJSOL,0))

 . D UP3^PSIVBCID(DFN,PSJNEWID,PSJSOL,PSJSOLX)

 K DA,DR,DIE,DIC

 S DA=PSJIDNO,DA(1)=DFN,DIE="^PS(55,"_DA(1)_",""IVBCMA"","

 S DR="5////RP" D ^DIE

 K DA,DR,DIE,DIC

 D ^PSIVHYPR:P(4)="H",^PSIVLABR:"APSC"[P(4) S:$D(ZTQUEUED) ZTREQ="@"

 ;PSJRPHD is defined so ^PSIVLABR won't print the header for sub-labels.

 S PSJRPHD=1

 ;If reprinting from war/man list, store new BCMA ID.

 S:$G(PSIVWMFL) PSIVID(PSJNEWID)=""

 Q

PRT ;

 S IONOFF="",IOP=PSIVPL,%ZIS="NQ" D ^%ZIS G:POP Q I IO=IO(0),($E(IOST)="C") W !!! D DEQIA,Q D HOME^%ZIS Q

 D HOME^%ZIS

 W ! S ZTDTH=$H,ZTIO=PSIVPL,ZTDESC="REPRINT INDIVIDUAL IV LABELS",ZTRTN="DEQIA^PSIVLBRP" F X="IONOFF","P16","PSIVAC","PSIVSN","PSIVSITE","DFN","ON","PSJSYSW0","PSJSYSU","PSJSYSP0","PSJIDLST(","P(","PSJY","PSIVCTD" S ZTSAVE(X)=""

 S:$D(PSIVCT) ZTSAVE("PSIVCT")="" D ^%ZTLOAD W:$D(ZTSK) !,"Queued."

 Q

Q ;

 Q

PSIVLBRP  ;BIR/MV - REPRINT LABELS FOR AN ORDER ;15 May 2001  3:29 PM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**58,97**;16 DEC 97

 +2       ;

 +3       ; Reference to ^PS(55 is supported by DBIA 2191.

 +4       ;

EN(PSJIDLST) ;

 +1        IF '$DATA(PSJIDLST)

               WRITE !,"No labels are available"

               DO PAUSE^VALM1

               QUIT 

 +2        NEW DIR,PSIVCTD

 +3        SET PSIVCT=1

 +4        WRITE !!,"Count as daily usage"

           SET %=1

           DO YN^DICN

           IF %=-1

               QUIT 

           SET PSIVCTD=$SELECT(%=1:1,1:0)

 +5        IF PSIVCTD=1

               KILL PSIVCT

 +6        SET PSJY=$$PROMPT()

 +7        IF PSJY=""

               QUIT 

 +8        DO PRT

 +9        QUIT 

PROMPT()  ;

 +1        WRITE !

 +2        SET DIR(0)="LOA^1:"_PSJIDLST

           SET DIR("A")="Select from 1 - "_PSJIDLST_" or <RETURN> to select by BCMA ID: "

           DO ^DIR

 +3        KILL DIR

 +4        SET PSJY=Y

 +5        IF PSJY=""

               SET DIR(0)="FOA^1:50^S X=$$UP^XLFSTR(X) K:'$D(PSJIDLST(X)) X"

               SET DIR("A")="Enter a BCMA ID: "

               DO ^DIR

               SET PSJY=$$UP^XLFSTR(Y)

 +6        KILL DIR

 +7        WRITE !!

 +8        QUIT PSJY

DEQIA     ;

 +1        SET PSIVNOL=0

 +2        FOR PSJSEL=1:1

               SET PSJSEL1=$PIECE(PSJY,",",PSJSEL)

               IF PSJSEL1=""

                   QUIT 

               SET PSIVNOL=PSIVNOL+1

 +3        FOR PSJSEL=1:1

               SET PSJSEL1=$PIECE(PSJY,",",PSJSEL)

               IF PSJSEL1=""

                   QUIT 

               Begin DoDot:1

 +4                IF 'PSIVCTD

                       SET PSIVCT=1

 +5                SET PSJID=$GET(PSJIDLST(PSJSEL1))

                   IF PSJID=""

                       QUIT 

                   DO REPRT(PSJID)

               End DoDot:1

 +6        KILL PSJRPHD

 +7        QUIT 

REPRT(PSJID) ;

 +1        SET PSJNEWID=$$BCMA^PSIVBCID(DFN,ON,$DATA(PSIVCT),$GET(PSIV1),$GET(PSIV2),$GET(PSIVNOL))

 +2        IF PSJNEWID=""

               WRITE !,"Can't get a new BCMA ID.  Try again"

               QUIT 

 +3        SET PSJIDNO=$PIECE(PSJID,"V",2)

 +4        SET PSIVBAG=$PIECE($GET(^PS(55,DFN,"IVBCMA",PSJIDNO,0)),U,8)

 +5        NEW DA,DR,DIE,DIC

 +6       ;S DIC(0)="L",DA=Y,DA(1)=DFN,X=PSJNEWID,DIC="^PS(55,"_DA(1)_",""IVBCMA""," D FILE^DICN

 +7        KILL DA,DR,DIE

           SET DIE="^PS(55,"_DFN_",""IVBCMA"","

           SET DA=$PIECE(PSJNEWID,"V",2)

           SET DA(1)=DFN

           DO NOW^%DTC

 +8       ;S DR=".02////"_+ON_";3////"_PSIVCTD_";4////"_$E(%,1,12)_";6////"_PSIVBAG D ^DIE

 +9        SET DR="6////"_PSIVBAG

           DO ^DIE

 +10       KILL DA,DR,DIE,DIC

 +11       SET PSJNEWID=$PIECE(PSJNEWID,"V",2)

 +12       FOR PSJAD=0:0

               SET PSJAD=$ORDER(^PS(55,DFN,"IVBCMA",PSJIDNO,"AD",PSJAD))

               IF 'PSJAD

                   QUIT 

               Begin DoDot:1

 +13               SET PSJADX=$GET(^PS(55,DFN,"IVBCMA",PSJIDNO,"AD",PSJAD,0))

 +14               DO UP2^PSIVBCID(DFN,PSJNEWID,PSJAD,PSJADX)

               End DoDot:1

 +15       FOR PSJSOL=0:0

               SET PSJSOL=$ORDER(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSJSOL))

               IF 'PSJSOL

                   QUIT 

               Begin DoDot:1

 +16               SET PSJSOLX=$GET(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSJSOL,0))

 +17               DO UP3^PSIVBCID(DFN,PSJNEWID,PSJSOL,PSJSOLX)

               End DoDot:1

 +18       KILL DA,DR,DIE,DIC

 +19       SET DA=PSJIDNO

           SET DA(1)=DFN

           SET DIE="^PS(55,"_DA(1)_",""IVBCMA"","

 +20       SET DR="5////RP"

           DO ^DIE

 +21       KILL DA,DR,DIE,DIC

 +22       IF P(4)="H"

               DO ^PSIVHYPR

           IF "APSC"[P(4)

               DO ^PSIVLABR

           IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +23      ;PSJRPHD is defined so ^PSIVLABR won't print the header for sub-labels.

 +24       SET PSJRPHD=1

 +25      ;If reprinting from war/man list, store new BCMA ID.

 +26       IF $GET(PSIVWMFL)

               SET PSIVID(PSJNEWID)=""

 +27       QUIT 

PRT       ;

 +1        SET IONOFF=""

           SET IOP=PSIVPL

           SET %ZIS="NQ"

           DO ^%ZIS

           IF POP

               GOTO Q

           IF IO=IO(0)

               IF ($EXTRACT(IOST)="C")

                   WRITE !!!

                   DO DEQIA

                   DO Q

                   DO HOME^%ZIS

                   QUIT 

 +2        DO HOME^%ZIS

 +3        WRITE !

           SET ZTDTH=$HOROLOG

           SET ZTIO=PSIVPL

           SET ZTDESC="REPRINT INDIVIDUAL IV LABELS"

           SET ZTRTN="DEQIA^PSIVLBRP"

           FOR X="IONOFF","P16","PSIVAC","PSIVSN","PSIVSITE","DFN","ON","PSJSYSW0","PSJSYSU","PSJSYSP0","PSJIDLST(","P(","PSJY","PSIVCTD"

               SET ZTSAVE(X)=""

 +4        IF $DATA(PSIVCT)

               SET ZTSAVE("PSIVCT")=""

           DO ^%ZTLOAD

           IF $DATA(ZTSK)

               WRITE !,"Queued."

 +5        QUIT 

Q         ;

 +1        QUIT