APSPRT ; IHS/DSD/ENM - PRINTS PREPACK AND U/D LABELS 7/22/89 ; [ 09/03/97 1:30 PM ]
;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97
;
START ;
D ^APSPRT1 ;Sets parameters
G:$D(APSPRT("QUIT")) END
BODY ;
D ADD ;Adds entry to APSP PREPACK LOG file.
I $D(APSPRT("QUIT")) G:APSPRT("QUIT")=1 END D EOJ G BODY
D ASK ;Asks if correct
I $D(APSPRT("QUIT")) D EOJ G BODY
I APSP("TYPE")="P" D EN^APSPRT1 ;Sets sig in correct array
D PRINT ;Print labels
G BODY
;
END D EOJ ;Clean up variables
Q ;End of routine
;
ADD ;
K APSPRT("ADD")
W !!,"Last Prepack Number : ",APSP("LASTP")
W " Last Unit Dose Number : ",APSP("LASTU"),!!
S DIC(0)="EQMALZ",DIC="^APSPP(31,",DIC("A")="IHS CONTROL # : "
D ^DIC
I +Y<0 S APSPRT("QUIT")=$S(X="":1,$D(DUOUT):"1",1:"") G ADDX
S DIE=DIC,(APSPRT("DA"),DA)=+Y,DR=$S($P(Y,U,3)=1:"[APSP PREPACK LOG ADD]",1:"[APSP PREPACK LOG EDIT]")
I $P(Y,U,3)=1 S APSPRT("ADD")=""
D ^DIE
I '$D(^APSPP(31,APSPRT("DA"),0)) S APSPRT("QUIT")="" G ADDX
; The following line of code deletes the entry if no pharmacist is
; entered and all the fields not filled in.
I $D(APSPRT("ADD")),$P(^APSPP(31,APSPRT("DA"),0),U,14)="" S DIK="^APSPP(31,",DA=APSPRT("DA") D ^DIK S APSPRT("QUIT")="" W !!,"DELETED !"
;
ADDX ;Exit point for ADD subroutine
Q
;
ASK ;Asks if label is correct
D SETVAR
D DISPLAY
W !!!,"IS THIS CORRECT (Y/N) "
S %=1 D YN^DICN
I %Y=""!(%Y="Y") D YES G ASKX
I %Y["?" W !,"Enter a 'Y' if you accept this log entry, a 'N' if not and",!,"you wish to continue to edit it. You may also enter a '^' if you want to",!,"delete this entry." G ASK
I %Y="^" S APSPRT("QUIT")="" S DIK="^APSPP(31,",DA=APSPRT("DA") D:$D(APSPRT("ADD")) ^DIK W:$D(APSPRT("ADD")) !!,"DELETED !" G ASKX
D DIE
G ASK
ASKX ;Exit point for ASK subroutine
Q
YES ;
S:APSP("TYPE")'="P"&(APSP(29)="y") APSP("COPIES")=APSP("COPIES")/2
I '$D(APSPRT("ADD")) G YESX
I APSP("TYPE")="P" S APSP("LASTP")=$E(APSP("CNTL#"),5,99)
I APSP("TYPE")'="P" S APSP("LASTU")=$E(APSP("CNTL#"),5,99)
S ^APSPP(31,"LAST")=APSP("LASTP")_U_APSP("LASTU")
YESX ;
Q
;
SETVAR ;Displays labels
I $D(^APSPP(31,DA,"TN")),^("TN")="" K ^("TN")
S APSPLOG=^APSPP(31,DA,0),APSPLBL=^APSPP(31.1,$P(APSPLOG,U,3),0)
S APSP("COPIES")=$P(APSPLOG,U,9),APSP("QTY")="#"_$P(APSPLOG,U,8)
S APSP("DRUG")=$S($D(^APSPP(31,DA,"TN")):^("TN"),$D(^PSDRUG($P(APSPLBL,U,1),0)):$P(^(0),U,1),1:"NONE")
S APSP("EXPDATE")=$P(APSPLOG,U,6),APSP("CNTL#")="CN# "_$P(APSPLOG,U,1)
S Y=APSP("EXPDATE") X ^DD("DD") S APSPRT("EXPDATE")="Expires: "_Y
I $L(APSPRT("EXPDATE"))+3+$L(APSP("CNTL#"))>APSP(22) S APSPRT("EXPDATE")="Exp: "_Y
S APSP("TYPE")=$S($P(APSPLOG,U,7)="P":"P",1:"U")
I APSP("TYPE")="U" S APSPRT("EXPDATE")="Exp:"_Y
G:APSP("TYPE")'="P" SETVARX
S (APSP("SIG"),X)=$P(APSPLBL,U,3) X ^DD(9009031.1,.03,9.2)
SETVARX ;
Q
DISPLAY ;Displays labels
I APSP("TYPE")="P" W !!!,$E(APSP("LINE1"),1,APSP(22)),!,APSP("SIG")
W:APSP("TYPE")'="P" !!
W !,APSP("DRUG"),?(APSP(22)-$L(APSP("QTY"))),APSP("QTY")
W !,APSP("CNTL#"),?(APSP(22)-$L(APSPRT("EXPDATE"))),APSPRT("EXPDATE")
W:APSP("TYPE")="P" !,$E(APSP("LINE2"),1,APSP(22))
Q
DIE ;
S DR="[APSP PREPACK LOG EDIT]"
D ^DIE
Q
PRINT ;
S APSP("PRT")=$S(APSP("TYPE")="P":"^APSPRT2",1:"^APSPRT3")
S %=1
W !!,"Do you wish to print the labels (Y/N) "
D YN^DICN
I %=0 W !,"If you wish the labels to be printed enter a 'Y',",!,"if not enter a 'N'. The prepack or unit dose is still recorded." G PRINT
G:%'=1 PRINTX
W !! S DIR("A")="Please enter the number of labels you wish to print : "_APSP("COPIES")_"// " ;IHS/DSD/ENM 05/24/96
S DIR(0)="FO^1:2" D ^DIR K DIR ;IHS/DSD/ENM 05/24/96
;R X:DTIME G:'$T PRINTX
I X'="",X<1!(X="^") G PRINTX ;IHS/OHPRD/JCM 9/22/89
I X?1N.N!(X="") S APSP("COPIES")=$S(X'="":X,1:APSP("COPIES"))
D:%=1 @APSP("PRT")
PRINTX ;
D EOJ ;Cleans up variables
Q
;
EOJ ;Clean up variables
K APSP("DRUG"),APSP("QTY"),APSPLOG,APSPLBL,DA,DIE,DIC
K APSP("CNTL#"),APSPIG,APSPRT("EXPDATE"),APSP("TYPE"),APSP("COPIES")
I $D(APSPRT("QUIT")),APSPRT("QUIT") K APSP,APSPRT
K X,Y,APSPRT("ADD"),%,%Y,APSPRT("QUIT"),APSP("QTYFLG")
K APSPGY,APSPGC,DIE,DIC,DIK,DR,II,IOP,POP,DUOUT,APSPZZL,APSPZM,APSPZLA
K APSPDR,APSPDR1,%ZIS,%ZIS
Q
APSPRT ; IHS/DSD/ENM - PRINTS PREPACK AND U/D LABELS 7/22/89 ; [ 09/03/97 1:30 PM ]
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97
+2 ;
START ;
+1 ;Sets parameters
DO ^APSPRT1
+2 IF $DATA(APSPRT("QUIT"))
GOTO END
BODY ;
+1 ;Adds entry to APSP PREPACK LOG file.
DO ADD
+2 IF $DATA(APSPRT("QUIT"))
IF APSPRT("QUIT")=1
GOTO END
DO EOJ
GOTO BODY
+3 ;Asks if correct
DO ASK
+4 IF $DATA(APSPRT("QUIT"))
DO EOJ
GOTO BODY
+5 ;Sets sig in correct array
IF APSP("TYPE")="P"
DO EN^APSPRT1
+6 ;Print labels
DO PRINT
+7 GOTO BODY
+8 ;
END ;Clean up variables
DO EOJ
+1 ;End of routine
QUIT
+2 ;
ADD ;
+1 KILL APSPRT("ADD")
+2 WRITE !!,"Last Prepack Number : ",APSP("LASTP")
+3 WRITE " Last Unit Dose Number : ",APSP("LASTU"),!!
+4 SET DIC(0)="EQMALZ"
SET DIC="^APSPP(31,"
SET DIC("A")="IHS CONTROL # : "
+5 DO ^DIC
+6 IF +Y<0
SET APSPRT("QUIT")=$SELECT(X="":1,$DATA(DUOUT):"1",1:"")
GOTO ADDX
+7 SET DIE=DIC
SET (APSPRT("DA"),DA)=+Y
SET DR=$SELECT($PIECE(Y,U,3)=1:"[APSP PREPACK LOG ADD]",1:"[APSP PREPACK LOG EDIT]")
+8 IF $PIECE(Y,U,3)=1
SET APSPRT("ADD")=""
+9 DO ^DIE
+10 IF '$DATA(^APSPP(31,APSPRT("DA"),0))
SET APSPRT("QUIT")=""
GOTO ADDX
+11 ; The following line of code deletes the entry if no pharmacist is
+12 ; entered and all the fields not filled in.
+13 IF $DATA(APSPRT("ADD"))
IF $PIECE(^APSPP(31,APSPRT("DA"),0),U,14)=""
SET DIK="^APSPP(31,"
SET DA=APSPRT("DA")
DO ^DIK
SET APSPRT("QUIT")=""
WRITE !!,"DELETED !"
+14 ;
ADDX ;Exit point for ADD subroutine
+1 QUIT
+2 ;
ASK ;Asks if label is correct
+1 DO SETVAR
+2 DO DISPLAY
+3 WRITE !!!,"IS THIS CORRECT (Y/N) "
+4 SET %=1
DO YN^DICN
+5 IF %Y=""!(%Y="Y")
DO YES
GOTO ASKX
+6 IF %Y["?"
WRITE !,"Enter a 'Y' if you accept this log entry, a 'N' if not and",!,"you wish to continue to edit it. You may also enter a '^' if you want to",!,"delete this entry."
GOTO ASK
+7 IF %Y="^"
SET APSPRT("QUIT")=""
SET DIK="^APSPP(31,"
SET DA=APSPRT("DA")
IF $DATA(APSPRT("ADD"))
DO ^DIK
IF $DATA(APSPRT("ADD"))
WRITE !!,"DELETED !"
GOTO ASKX
+8 DO DIE
+9 GOTO ASK
ASKX ;Exit point for ASK subroutine
+1 QUIT
YES ;
+1 IF APSP("TYPE")'="P"&(APSP(29)="y")
SET APSP("COPIES")=APSP("COPIES")/2
+2 IF '$DATA(APSPRT("ADD"))
GOTO YESX
+3 IF APSP("TYPE")="P"
SET APSP("LASTP")=$EXTRACT(APSP("CNTL#"),5,99)
+4 IF APSP("TYPE")'="P"
SET APSP("LASTU")=$EXTRACT(APSP("CNTL#"),5,99)
+5 SET ^APSPP(31,"LAST")=APSP("LASTP")_U_APSP("LASTU")
YESX ;
+1 QUIT
+2 ;
SETVAR ;Displays labels
+1 IF $DATA(^APSPP(31,DA,"TN"))
IF ^("TN")=""
KILL ^("TN")
+2 SET APSPLOG=^APSPP(31,DA,0)
SET APSPLBL=^APSPP(31.1,$PIECE(APSPLOG,U,3),0)
+3 SET APSP("COPIES")=$PIECE(APSPLOG,U,9)
SET APSP("QTY")="#"_$PIECE(APSPLOG,U,8)
+4 SET APSP("DRUG")=$SELECT($DATA(^APSPP(31,DA,"TN")):^("TN"),$DATA(^PSDRUG($PIECE(APSPLBL,U,1),0)):$PIECE(^(0),U,1),1:"NONE")
+5 SET APSP("EXPDATE")=$PIECE(APSPLOG,U,6)
SET APSP("CNTL#")="CN# "_$PIECE(APSPLOG,U,1)
+6 SET Y=APSP("EXPDATE")
XECUTE ^DD("DD")
SET APSPRT("EXPDATE")="Expires: "_Y
+7 IF $LENGTH(APSPRT("EXPDATE"))+3+$LENGTH(APSP("CNTL#"))>APSP(22)
SET APSPRT("EXPDATE")="Exp: "_Y
+8 SET APSP("TYPE")=$SELECT($PIECE(APSPLOG,U,7)="P":"P",1:"U")
+9 IF APSP("TYPE")="U"
SET APSPRT("EXPDATE")="Exp:"_Y
+10 IF APSP("TYPE")'="P"
GOTO SETVARX
+11 SET (APSP("SIG"),X)=$PIECE(APSPLBL,U,3)
XECUTE ^DD(9009031.1,.03,9.2)
SETVARX ;
+1 QUIT
DISPLAY ;Displays labels
+1 IF APSP("TYPE")="P"
WRITE !!!,$EXTRACT(APSP("LINE1"),1,APSP(22)),!,APSP("SIG")
+2 IF APSP("TYPE")'="P"
WRITE !!
+3 WRITE !,APSP("DRUG"),?(APSP(22)-$LENGTH(APSP("QTY"))),APSP("QTY")
+4 WRITE !,APSP("CNTL#"),?(APSP(22)-$LENGTH(APSPRT("EXPDATE"))),APSPRT("EXPDATE")
+5 IF APSP("TYPE")="P"
WRITE !,$EXTRACT(APSP("LINE2"),1,APSP(22))
+6 QUIT
DIE ;
+1 SET DR="[APSP PREPACK LOG EDIT]"
+2 DO ^DIE
+3 QUIT
PRINT ;
+1 SET APSP("PRT")=$SELECT(APSP("TYPE")="P":"^APSPRT2",1:"^APSPRT3")
+2 SET %=1
+3 WRITE !!,"Do you wish to print the labels (Y/N) "
+4 DO YN^DICN
+5 IF %=0
WRITE !,"If you wish the labels to be printed enter a 'Y',",!,"if not enter a 'N'. The prepack or unit dose is still recorded."
GOTO PRINT
+6 IF %'=1
GOTO PRINTX
+7 ;IHS/DSD/ENM 05/24/96
WRITE !!
SET DIR("A")="Please enter the number of labels you wish to print : "_APSP("COPIES")_"// "
+8 ;IHS/DSD/ENM 05/24/96
SET DIR(0)="FO^1:2"
DO ^DIR
KILL DIR
+9 ;R X:DTIME G:'$T PRINTX
+10 ;IHS/OHPRD/JCM 9/22/89
IF X'=""
IF X<1!(X="^")
GOTO PRINTX
+11 IF X?1N.N!(X="")
SET APSP("COPIES")=$SELECT(X'="":X,1:APSP("COPIES"))
+12 IF %=1
DO @APSP("PRT")
PRINTX ;
+1 ;Cleans up variables
DO EOJ
+2 QUIT
+3 ;
EOJ ;Clean up variables
+1 KILL APSP("DRUG"),APSP("QTY"),APSPLOG,APSPLBL,DA,DIE,DIC
+2 KILL APSP("CNTL#"),APSPIG,APSPRT("EXPDATE"),APSP("TYPE"),APSP("COPIES")
+3 IF $DATA(APSPRT("QUIT"))
IF APSPRT("QUIT")
KILL APSP,APSPRT
+4 KILL X,Y,APSPRT("ADD"),%,%Y,APSPRT("QUIT"),APSP("QTYFLG")
+5 KILL APSPGY,APSPGC,DIE,DIC,DIK,DR,II,IOP,POP,DUOUT,APSPZZL,APSPZM,APSPZLA
+6 KILL APSPDR,APSPDR1,%ZIS,%ZIS
+7 QUIT
