PSJPADIU ;BP/VGH-INPATIENT PADE INVENTORY FILE UTILITIES ;3/20/18 8:35 AM
;;5.0;INPATIENT MEDICATIONS ;**356**;16 DEC 97;Build 7
;Per VHA Directive 2004-038, this routine should not be modified.
;
FILDEV(PADATA,ERRMSG) ; File PADE DEVICE to PADE INVENTORY file
N FDA,PSJPSYS,PSJSCR,PSJSCR
I '($G(PADATA(2))]"") S ERRMSG="MISSING PADE DEVICE" Q 0
I $G(PSJPSYS),$G(^PS(58.601,+PSJPSYS,0))]"" S PADATA("SYS IEN")=PSJPSYS
S PSJPSYS=PADATA("SYS IEN"),PSJSCR="I $S('$G(PSJPSYS):1,1:PSJPSYS=$P(^(0),U,2))"
I ($G(PADATA(1))=""&$G(PSJPSYS)) S PADATA(1)=$P(^PS(58.601,PSJPSYS,0),"^")
K ERR S PADATA("DEVICE IEN")=$$FIND1^DIC(58.63,,"X",PADATA(2),,PSJSCR,"ERR") K DIERR ;*356- remove M (multiple index lookup)
I '$G(PADATA("DEVICE IEN")) D
.N FDA S FDA(58.63,"?+1,",.01)=PADATA(2)
.S FDA(58.63,"?+1,",1)=PADATA(1)
.S FDA(58.63,"?+1,",12)=$$UPPER^PSJPDRUT(PADATA(2))
.K ERR,DIERR D UPDATE^DIE("E","FDA","","ERR") K DIERR ;*356
.K ERR,DIERR S PADATA("DEVICE IEN")=$$FIND1^DIC(58.63,,"X",PADATA(2),,PSJSCR,"ERR") K DIERR ;*356- remove M (multiple index lookup)
I $G(PADATA("DEVICE IEN")) D
.N FDA S FDA(58.6011,"?+1,"_PADATA("SYS IEN")_",",.01)=PADATA(2) K ERR D UPDATE^DIE("E","FDA","","ERR") K DIERR ;*356
.K ERR,DIERR S PADATA("DEVICE IEN")=$$FIND1^DIC(58.6011,","_PADATA("SYS IEN")_",","BX",PADATA(2),,,"ERR") K DIERR ;*356- replaced M (multiple index lookup) with B
I '$G(PADATA("DEVICE IEN")) S ERRMSG="Unable to file PADE Device "_PADATA(2) Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPADIU 1485 printed Dec 13, 2024@02:08:37 Page 2
PSJPADIU ;BP/VGH-INPATIENT PADE INVENTORY FILE UTILITIES ;3/20/18 8:35 AM
+1 ;;5.0;INPATIENT MEDICATIONS ;**356**;16 DEC 97;Build 7
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
FILDEV(PADATA,ERRMSG) ; File PADE DEVICE to PADE INVENTORY file
+1 NEW FDA,PSJPSYS,PSJSCR,PSJSCR
+2 IF '($GET(PADATA(2))]"")
SET ERRMSG="MISSING PADE DEVICE"
QUIT 0
+3 IF $GET(PSJPSYS)
IF $GET(^PS(58.601,+PSJPSYS,0))]""
SET PADATA("SYS IEN")=PSJPSYS
+4 SET PSJPSYS=PADATA("SYS IEN")
SET PSJSCR="I $S('$G(PSJPSYS):1,1:PSJPSYS=$P(^(0),U,2))"
+5 IF ($GET(PADATA(1))=""&$GET(PSJPSYS))
SET PADATA(1)=$PIECE(^PS(58.601,PSJPSYS,0),"^")
+6 ;*356- remove M (multiple index lookup)
KILL ERR
SET PADATA("DEVICE IEN")=$$FIND1^DIC(58.63,,"X",PADATA(2),,PSJSCR,"ERR")
KILL DIERR
+7 IF '$GET(PADATA("DEVICE IEN"))
Begin DoDot:1
+8 NEW FDA
SET FDA(58.63,"?+1,",.01)=PADATA(2)
+9 SET FDA(58.63,"?+1,",1)=PADATA(1)
+10 SET FDA(58.63,"?+1,",12)=$$UPPER^PSJPDRUT(PADATA(2))
+11 ;*356
KILL ERR,DIERR
DO UPDATE^DIE("E","FDA","","ERR")
KILL DIERR
+12 ;*356- remove M (multiple index lookup)
KILL ERR,DIERR
SET PADATA("DEVICE IEN")=$$FIND1^DIC(58.63,,"X",PADATA(2),,PSJSCR,"ERR")
KILL DIERR
End DoDot:1
+13 IF $GET(PADATA("DEVICE IEN"))
Begin DoDot:1
+14 ;*356
NEW FDA
SET FDA(58.6011,"?+1,"_PADATA("SYS IEN")_",",.01)=PADATA(2)
KILL ERR
DO UPDATE^DIE("E","FDA","","ERR")
KILL DIERR
+15 ;*356- replaced M (multiple index lookup) with B
KILL ERR,DIERR
SET PADATA("DEVICE IEN")=$$FIND1^DIC(58.6011,","_PADATA("SYS IEN")_",","BX",PADATA(2),,,"ERR")
KILL DIERR
End DoDot:1
+16 IF '$GET(PADATA("DEVICE IEN"))
SET ERRMSG="Unable to file PADE Device "_PADATA(2)
QUIT 0
+17 QUIT 1