PSOFDAUT ;BIRM/MFR - FDA Med Guide Utilities ; 07 Jun 2005 8:39 PM
;;7.0;OUTPATIENT PHARMACY;**367**;DEC 1997;Build 62
;External reference to $$FDAMG^PSNAPIS supported by DBIA 2531
;
SELPRT(DEFAULT) ; FDA Med Guide Printer Selection
;Input: DEFAULT - Default Printer Name
;Return Variable: SELPRT: Selected Printer Name ^ Windows Network Printer Name
;
N SELPRT,NTWRKNAM,DEFPRT,%ZIS,VALID,DEVIEN,PRTLST,I
;
; If FDA MG PRINT SERVER is not present quits (FDA MG Functionality is OFF)
I $$GET1^DIQ(59,PSOSITE,134)="" Q "^"
;
S SELPRT=$G(DEFAULT) D ^%ZISC
I SELPRT'="" D
. S DEFPRT=SELPRT
E D
. S DEFPRT=$$DEFPRT(PSOSITE)
;
D PRTLST(PSOSITE,.PRTLST)
I $O(PRTLST(0)) D
. W !!,$$GET1^DIQ(59,PSOSITE,.01),"'s FDA Medication Guide Printer(s) on file:",!
. F I=0:0 S I=$O(PRTLST(I)) Q:'I W !?5,$P(PRTLST(I),"^",2)
;
PRT ; Printer prompt
S %ZIS="MNQ",%ZIS("A")="Select FDA MED GUIDE PRINTER: "
S:$G(DEFPRT)'="" %ZIS("B")=$P(DEFPRT,"^") W ! D ^%ZIS K %ZIS,IO("Q"),IOP I POP Q "^"
S VALID=1
I (IO'=IO(0)) D I 'VALID D ^%ZISC G PRT
. S DEVIEN=IOS,NTWRKNAM=$$GET1^DIQ(3.5,IOS,75)
. I (NTWRKNAM=""&(" "_ION_" "'[" NULL ")) D S VALID=0 Q
. . W !,"This device cannot be used for printing FDA Medication Guides."
. . W !,"Please, contact your IRM and ask them to update the Windows"
. . W !,"Network Printer Name for this device.",$C(7)
. E D
. . S SELPRT=ION_"^"_NTWRKNAM
;
; HOME device selected
I (IO=IO(0)) S SELPRT=""
;
D ^%ZISC
;
Q SELPRT
;
PRTLST(SITE,PRTLST) ; Returns the List of FDA Medication Guide Printer for the Division
; Input: (r) SITE - Site IEN (#59)
; Output: PRTLST - Array containing list of FDA Med Guides Printers for the Division
N PRT,CNT
S CNT=0
F PRT=0:0 S PRT=$O(^PS(59,+$G(SITE),"FDA",PRT)) Q:'PRT D
. S CNT=CNT+1
. S PRTLST(CNT)=$$GET1^DIQ(59.0135,PRT_","_+$G(SITE)_",",.01)_"^"_$$GET1^DIQ(59.0135,PRT_","_+$G(SITE)_",",.01)
. S:$$GET1^DIQ(59.0135,PRT_","_+$G(SITE)_",",.02,"I") PRTLST(CNT)=PRTLST(CNT)_" (Default)"
Q
;
DEFPRT(SITE) ; Returns the Default FDA Medication Guide Printer for the Division
; Input: (r) SITE - Site IEN (#59)
; Output: DEFPRT - Device Name or blank (no Default)
N PRT,DEFPRT
S DEFPRT=""
F PRT=0:0 S PRT=$O(^PS(59,+$G(SITE),"FDA",PRT)) Q:'PRT D
. I $P($G(^PS(59,+$G(SITE),"FDA",PRT,0)),"^",2) D
. . S PRTIEN=$$GET1^DIQ(59.0135,PRT_","_+$G(SITE)_",",.01,"I") I 'PRTIEN Q
. . I $$GET1^DIQ(3.5,PRTIEN,75)="" Q
. . S DEFPRT=$$GET1^DIQ(3.5,PRTIEN,.01)_"^"_$$GET1^DIQ(3.5,PRTIEN,75)
Q DEFPRT
;
FDAMGDOC(RXIEN) ; Lists all FDA Med Guides for a specific Rx & Return Selection
; Input: (r) RXIEN - Prescription IEN (#52)
; Output: FDAMGDOC - FDA Med Guide PDF file name or blank, "^" (no selection)
;
ASK ; Prompt for FDA Medication Guide Selection
N MGLST,DIR,DIRUT,DUOUT,DTOUT
D FDAMGLST(RXIEN,1,.MGLST) D HELP W !
S DIR(0)="FO",DIR("A")="Select FDA Med Guide (1-"_$O(MGLST(999),-1)_")"
S (DIR("?"),DIR("??"))="^D HELP^PSOFDAUT" D ^DIR
I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) Q "^"
I '$D(MGLST(X)) W ?40,"Invalid selection.",$C(7) G ASK
W " ",$P(MGLST(X),"^",2)
Q $P(MGLST(X),"^",2)
;
HELP ; List FDA Med Guides and prompt for selection
N INDEX,XX
S XX="",$P(XX,"-",81)=""
W !,XX,!," # FL",?7,"FDA MED GUIDE FILE NAME",?64,"TYPE",?72,"DATE",!,XX
S INDEX=0 F S INDEX=$O(MGLST(INDEX)) Q:'INDEX D
. W:'$O(MGLST(INDEX)) !
. W !,$J(INDEX,2),?3,$J($P(MGLST(INDEX),"^"),2),?7,$P(MGLST(INDEX),"^",2)
. W ?64,$P(MGLST(INDEX),"^",3),?72,$P(MGLST(INDEX),"^",4)
Q
;
FDAMGLST(RXIEN,ADDLST,MGLST) ; Return a list of all FDA Med Guides for a specific Rx
; Input: (r) RXIEN - Prescription IEN (#52)
; (o) ADDLST - Add Latest FDA Med Guide to the list? (Default: 0 (No))
; Output: MGLST - Array containing list of FDA Med Guides for the Rx (By Reference)
N A,B,Z,LBL,CMP,FDAMG,RFL,DRGIEN,NDFIEN,FILL,INDEX,TMPLST,MGDATE
;
K TMPLST
; Window Fills
S LBL=0 F S LBL=$O(^PSRX(RXIEN,"L",LBL)) Q:'LBL D
. S FDAMG=$G(^PSRX(RXIEN,"L",LBL,"FDA")) I FDAMG="" Q
. S Z=$G(^PSRX(RXIEN,"L",LBL,0)) S FILL=+$P(Z,"^",2) I (FILL>20) S FILL="P"_(99-FILL)
. S MGDATE=$$GET1^DIQ(52.032,LBL_","_RXIEN_",",.01,"I")\1
. S TMPLST(MGDATE,FILL)=FILL_"^"_FDAMG_"^"_$S(FILL["P":"PARTIAL",1:"WINDOW")_"^"_$$FMTE^XLFDT(MGDATE,"2ZM")
;
; CMOP Fills
S CMP=0 F S CMP=$O(^PSRX(RXIEN,4,CMP)) Q:'CMP D
. S FDAMG=$G(^PSRX(RXIEN,4,CMP,"FDA")) I FDAMG="" Q
. S Z=$G(^PSRX(RXIEN,4,CMP,0)) Q:'+Z
. S MGDATE=$$GET1^DIQ(550.2,+Z,5,"I")\1
. S TMPLST(MGDATE,+$P(Z,"^",3))=+$P(Z,"^",3)_"^"_FDAMG_"^CMOP^"_$$FMTE^XLFDT(MGDATE,"2ZM")
;
; - Moving from TMPLST to MGLST
K MGLST S INDEX=0,(A,B)=""
F S A=$O(TMPLST(A)) Q:A="" F S B=$O(TMPLST(A,B)) Q:B="" D
. S INDEX=INDEX+1,MGLST(INDEX)=TMPLST(A,B)
;
; - Adding 'LATEST' FDA Med Guide
I $G(ADDLST) D
. S DRGIEN=$$GET1^DIQ(52,RXIEN,6,"I"),NDFIEN=$$GET1^DIQ(50,DRGIEN,22,"I")
. I ($$FDAMG^PSNAPIS(NDFIEN)'="") D
. . S INDEX=INDEX+1,MGLST(INDEX)="^"_$$FDAMG^PSNAPIS(NDFIEN)_"^LATEST"
;
Q
;
MGONFILE(RXIEN) ; Is there an FDA Med Guide on File for the Prescription
; Input: (r) RXIEN - Pointer to the PRESCRIPTION file (#52)
;Output: 1^FDA Med Guide Document Name / 0 (no)
;
N DRGIEN,NDFIEN,FDAMGFN
I '$D(^PSRX(RXIEN)) Q 0
S DRGIEN=$P($G(^PSRX(RXIEN,0)),"^",6)
I '$D(^PSDRUG(DRGIEN)) Q 0
S NDFIEN=+$P($G(^PSDRUG(DRGIEN,"ND")),"^",3) I 'NDFIEN Q 0
S FDAMGFN=$$FDAMG^PSNAPIS(NDFIEN) I FDAMGFN="" Q 0
Q ("1^"_FDAMGFN)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOFDAUT 5540 printed Sep 23, 2025@20:05:48 Page 2
PSOFDAUT ;BIRM/MFR - FDA Med Guide Utilities ; 07 Jun 2005 8:39 PM
+1 ;;7.0;OUTPATIENT PHARMACY;**367**;DEC 1997;Build 62
+2 ;External reference to $$FDAMG^PSNAPIS supported by DBIA 2531
+3 ;
SELPRT(DEFAULT) ; FDA Med Guide Printer Selection
+1 ;Input: DEFAULT - Default Printer Name
+2 ;Return Variable: SELPRT: Selected Printer Name ^ Windows Network Printer Name
+3 ;
+4 NEW SELPRT,NTWRKNAM,DEFPRT,%ZIS,VALID,DEVIEN,PRTLST,I
+5 ;
+6 ; If FDA MG PRINT SERVER is not present quits (FDA MG Functionality is OFF)
+7 IF $$GET1^DIQ(59,PSOSITE,134)=""
QUIT "^"
+8 ;
+9 SET SELPRT=$GET(DEFAULT)
DO ^%ZISC
+10 IF SELPRT'=""
Begin DoDot:1
+11 SET DEFPRT=SELPRT
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 SET DEFPRT=$$DEFPRT(PSOSITE)
End DoDot:1
+14 ;
+15 DO PRTLST(PSOSITE,.PRTLST)
+16 IF $ORDER(PRTLST(0))
Begin DoDot:1
+17 WRITE !!,$$GET1^DIQ(59,PSOSITE,.01),"'s FDA Medication Guide Printer(s) on file:",!
+18 FOR I=0:0
SET I=$ORDER(PRTLST(I))
if 'I
QUIT
WRITE !?5,$PIECE(PRTLST(I),"^",2)
End DoDot:1
+19 ;
PRT ; Printer prompt
+1 SET %ZIS="MNQ"
SET %ZIS("A")="Select FDA MED GUIDE PRINTER: "
+2 if $GET(DEFPRT)'=""
SET %ZIS("B")=$PIECE(DEFPRT,"^")
WRITE !
DO ^%ZIS
KILL %ZIS,IO("Q"),IOP
IF POP
QUIT "^"
+3 SET VALID=1
+4 IF (IO'=IO(0))
Begin DoDot:1
+5 SET DEVIEN=IOS
SET NTWRKNAM=$$GET1^DIQ(3.5,IOS,75)
+6 IF (NTWRKNAM=""&(" "_ION_" "'[" NULL "))
Begin DoDot:2
+7 WRITE !,"This device cannot be used for printing FDA Medication Guides."
+8 WRITE !,"Please, contact your IRM and ask them to update the Windows"
+9 WRITE !,"Network Printer Name for this device.",$CHAR(7)
End DoDot:2
SET VALID=0
QUIT
+10 IF '$TEST
Begin DoDot:2
+11 SET SELPRT=ION_"^"_NTWRKNAM
End DoDot:2
End DoDot:1
IF 'VALID
DO ^%ZISC
GOTO PRT
+12 ;
+13 ; HOME device selected
+14 IF (IO=IO(0))
SET SELPRT=""
+15 ;
+16 DO ^%ZISC
+17 ;
+18 QUIT SELPRT
+19 ;
PRTLST(SITE,PRTLST) ; Returns the List of FDA Medication Guide Printer for the Division
+1 ; Input: (r) SITE - Site IEN (#59)
+2 ; Output: PRTLST - Array containing list of FDA Med Guides Printers for the Division
+3 NEW PRT,CNT
+4 SET CNT=0
+5 FOR PRT=0:0
SET PRT=$ORDER(^PS(59,+$GET(SITE),"FDA",PRT))
if 'PRT
QUIT
Begin DoDot:1
+6 SET CNT=CNT+1
+7 SET PRTLST(CNT)=$$GET1^DIQ(59.0135,PRT_","_+$GET(SITE)_",",.01)_"^"_$$GET1^DIQ(59.0135,PRT_","_+$GET(SITE)_",",.01)
+8 if $$GET1^DIQ(59.0135,PRT_","_+$GET(SITE)_",",.02,"I")
SET PRTLST(CNT)=PRTLST(CNT)_" (Default)"
End DoDot:1
+9 QUIT
+10 ;
DEFPRT(SITE) ; Returns the Default FDA Medication Guide Printer for the Division
+1 ; Input: (r) SITE - Site IEN (#59)
+2 ; Output: DEFPRT - Device Name or blank (no Default)
+3 NEW PRT,DEFPRT
+4 SET DEFPRT=""
+5 FOR PRT=0:0
SET PRT=$ORDER(^PS(59,+$GET(SITE),"FDA",PRT))
if 'PRT
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^PS(59,+$GET(SITE),"FDA",PRT,0)),"^",2)
Begin DoDot:2
+7 SET PRTIEN=$$GET1^DIQ(59.0135,PRT_","_+$GET(SITE)_",",.01,"I")
IF 'PRTIEN
QUIT
+8 IF $$GET1^DIQ(3.5,PRTIEN,75)=""
QUIT
+9 SET DEFPRT=$$GET1^DIQ(3.5,PRTIEN,.01)_"^"_$$GET1^DIQ(3.5,PRTIEN,75)
End DoDot:2
End DoDot:1
+10 QUIT DEFPRT
+11 ;
FDAMGDOC(RXIEN) ; Lists all FDA Med Guides for a specific Rx & Return Selection
+1 ; Input: (r) RXIEN - Prescription IEN (#52)
+2 ; Output: FDAMGDOC - FDA Med Guide PDF file name or blank, "^" (no selection)
+3 ;
ASK ; Prompt for FDA Medication Guide Selection
+1 NEW MGLST,DIR,DIRUT,DUOUT,DTOUT
+2 DO FDAMGLST(RXIEN,1,.MGLST)
DO HELP
WRITE !
+3 SET DIR(0)="FO"
SET DIR("A")="Select FDA Med Guide (1-"_$ORDER(MGLST(999),-1)_")"
+4 SET (DIR("?"),DIR("??"))="^D HELP^PSOFDAUT"
DO ^DIR
+5 IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)
QUIT "^"
+6 IF '$DATA(MGLST(X))
WRITE ?40,"Invalid selection.",$CHAR(7)
GOTO ASK
+7 WRITE " ",$PIECE(MGLST(X),"^",2)
+8 QUIT $PIECE(MGLST(X),"^",2)
+9 ;
HELP ; List FDA Med Guides and prompt for selection
+1 NEW INDEX,XX
+2 SET XX=""
SET $PIECE(XX,"-",81)=""
+3 WRITE !,XX,!," # FL",?7,"FDA MED GUIDE FILE NAME",?64,"TYPE",?72,"DATE",!,XX
+4 SET INDEX=0
FOR
SET INDEX=$ORDER(MGLST(INDEX))
if 'INDEX
QUIT
Begin DoDot:1
+5 if '$ORDER(MGLST(INDEX))
WRITE !
+6 WRITE !,$JUSTIFY(INDEX,2),?3,$JUSTIFY($PIECE(MGLST(INDEX),"^"),2),?7,$PIECE(MGLST(INDEX),"^",2)
+7 WRITE ?64,$PIECE(MGLST(INDEX),"^",3),?72,$PIECE(MGLST(INDEX),"^",4)
End DoDot:1
+8 QUIT
+9 ;
FDAMGLST(RXIEN,ADDLST,MGLST) ; Return a list of all FDA Med Guides for a specific Rx
+1 ; Input: (r) RXIEN - Prescription IEN (#52)
+2 ; (o) ADDLST - Add Latest FDA Med Guide to the list? (Default: 0 (No))
+3 ; Output: MGLST - Array containing list of FDA Med Guides for the Rx (By Reference)
+4 NEW A,B,Z,LBL,CMP,FDAMG,RFL,DRGIEN,NDFIEN,FILL,INDEX,TMPLST,MGDATE
+5 ;
+6 KILL TMPLST
+7 ; Window Fills
+8 SET LBL=0
FOR
SET LBL=$ORDER(^PSRX(RXIEN,"L",LBL))
if 'LBL
QUIT
Begin DoDot:1
+9 SET FDAMG=$GET(^PSRX(RXIEN,"L",LBL,"FDA"))
IF FDAMG=""
QUIT
+10 SET Z=$GET(^PSRX(RXIEN,"L",LBL,0))
SET FILL=+$PIECE(Z,"^",2)
IF (FILL>20)
SET FILL="P"_(99-FILL)
+11 SET MGDATE=$$GET1^DIQ(52.032,LBL_","_RXIEN_",",.01,"I")\1
+12 SET TMPLST(MGDATE,FILL)=FILL_"^"_FDAMG_"^"_$SELECT(FILL["P":"PARTIAL",1:"WINDOW")_"^"_$$FMTE^XLFDT(MGDATE,"2ZM")
End DoDot:1
+13 ;
+14 ; CMOP Fills
+15 SET CMP=0
FOR
SET CMP=$ORDER(^PSRX(RXIEN,4,CMP))
if 'CMP
QUIT
Begin DoDot:1
+16 SET FDAMG=$GET(^PSRX(RXIEN,4,CMP,"FDA"))
IF FDAMG=""
QUIT
+17 SET Z=$GET(^PSRX(RXIEN,4,CMP,0))
if '+Z
QUIT
+18 SET MGDATE=$$GET1^DIQ(550.2,+Z,5,"I")\1
+19 SET TMPLST(MGDATE,+$PIECE(Z,"^",3))=+$PIECE(Z,"^",3)_"^"_FDAMG_"^CMOP^"_$$FMTE^XLFDT(MGDATE,"2ZM")
End DoDot:1
+20 ;
+21 ; - Moving from TMPLST to MGLST
+22 KILL MGLST
SET INDEX=0
SET (A,B)=""
+23 FOR
SET A=$ORDER(TMPLST(A))
if A=""
QUIT
FOR
SET B=$ORDER(TMPLST(A,B))
if B=""
QUIT
Begin DoDot:1
+24 SET INDEX=INDEX+1
SET MGLST(INDEX)=TMPLST(A,B)
End DoDot:1
+25 ;
+26 ; - Adding 'LATEST' FDA Med Guide
+27 IF $GET(ADDLST)
Begin DoDot:1
+28 SET DRGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
SET NDFIEN=$$GET1^DIQ(50,DRGIEN,22,"I")
+29 IF ($$FDAMG^PSNAPIS(NDFIEN)'="")
Begin DoDot:2
+30 SET INDEX=INDEX+1
SET MGLST(INDEX)="^"_$$FDAMG^PSNAPIS(NDFIEN)_"^LATEST"
End DoDot:2
End DoDot:1
+31 ;
+32 QUIT
+33 ;
MGONFILE(RXIEN) ; Is there an FDA Med Guide on File for the Prescription
+1 ; Input: (r) RXIEN - Pointer to the PRESCRIPTION file (#52)
+2 ;Output: 1^FDA Med Guide Document Name / 0 (no)
+3 ;
+4 NEW DRGIEN,NDFIEN,FDAMGFN
+5 IF '$DATA(^PSRX(RXIEN))
QUIT 0
+6 SET DRGIEN=$PIECE($GET(^PSRX(RXIEN,0)),"^",6)
+7 IF '$DATA(^PSDRUG(DRGIEN))
QUIT 0
+8 SET NDFIEN=+$PIECE($GET(^PSDRUG(DRGIEN,"ND")),"^",3)
IF 'NDFIEN
QUIT 0
+9 SET FDAMGFN=$$FDAMG^PSNAPIS(NDFIEN)
IF FDAMGFN=""
QUIT 0
+10 QUIT ("1^"_FDAMGFN)
