DGPTAPA1 ;ALB/MTC - PTF A/P ARCHIVE UTILITY ; 10-19-92
;;5.3;Registration;;Aug 13, 1993
;
ARINT ;
D ARMAIN,AR401^DGPTAPA2,AR601^DGPTAPA2,AR501^DGPTAPA3,AR535^DGPTAPA3
Q
;
ARMAIN ;-- This function will load the array containing the
; PTF detailed information.
; INPUT : DGPTF - Valid PTF entry
; DGTMP - IEN of the template used
;
N I,X,Y,DG70,NUMREC,SEQ,OSEQ,REF
;--
S OSEQ=$G(^DGP(45.62,DGTMP,100,0)) Q:OSEQ']""
S SEQ=$P(OSEQ,U,3),REF="^DGP(45.62,"_DGTMP_",100)"
S DG70=$G(^DGPT(DGPTF,70))
;
;--patient name (2)
S Y=DGPTF_U_$P(^DPT(+^DGPT(DGPTF,0),0),U)
;--admission date (3)
S Y=Y_U_$P(^DGPT(DGPTF,0),U,2)
;--discharge date (4)
S Y=Y_U_$S(+DG70:+DG70,1:"")
;--discharge specilaty (5)
S Y=Y_U_$S($P(DG70,U,2):$P(^DIC(42.4,$P(DG70,U,2),0),U),1:""),X=$P(DG70,U,3)
;--type of disposition (6)
S Y=Y_U_$S(X:$P($P($P(^DD(45,72,0),U,3),";",X),":",2),1:"")
S X=$P(DG70,U,14)
;--discharge status (7)
S Y=Y_U_$S(X:$P($P($P(^DD(45,72.1,0),U,3),";",X),":",2),1:"")
S X=$P(DG70,U,4)
;--outpatient treatment (8)
S Y=Y_U_$S(X=1:"YES",1:"NO")
;-- ASIH days (9)
S Y=Y_U_$S($P(DG70,U,8)]"":$P(DG70,U,8),1:"")
S X=$P(DG70,U,9)
;-- C&P Status (10)
S Y=Y_U_$S(X:$P($P($P(^DD(45,78,0),U,3),";",X),":",2),1:"")
;-- VA Auspices (11)
S Y=Y_U_$S($P(DG70,U,5)=1:"YES",1:"NO")
;-- income (12)
S DGINC=$P($G(^DGPT(DGPTF,101)),U,7)
S Y=Y_U_$S(DGINC]"":DGINC,1:"")
;
;-- check for ICD codes (13-22)
F I=10,15:1:24 D
. S Y=Y_U_$S($P(DG70,U,I):$P(^ICD9($P(DG70,U,I),0),U),1:"")
;
;-- check for 300 node information (23-28)
S X=$G(^DGPT(DGPTF,300))
S Y=Y_U_$$AR300(X),SEQ=SEQ+1,@REF@(SEQ,0)=Y
;
;-- update
S $P(^DGP(45.62,DGTMP,100,0),U,3,4)=SEQ_U_SEQ
;
Q
;
AR300(N300) ;-- load 300 node information
; INPUT N300 - Contains 300 node
; OUTPUT - Load display array
;
N Y,X
;-- suicide indicator
S Y=$S($P(N300,U,2)=1:"Attempted",$P(N300,U,2)=2:"Accomplished",1:"")_U
;-- legionnaire's
S Y=Y_$S($P(N300,U,3)=1:"YES",1:"NO")_U
;-- abused substance
S Y=Y_$S($P(N300,U,4):$P($G(^DIC(45.61,$P(N300,U,4),0)),U),1:"")_U
;-- psych class severity
I $P(N300,U,5)]"" D
. S X=$P(N300,U,5)
. S Y=Y_$S(X]"":$P($P($P(^DD(45.02,300.05,0),U,3),";",X),":",2),1:"")_U
I $P(N300,U,5)="" S Y=Y_U
;-- current func assessment
S Y=Y_$S($P(N300,U,6):$P(N300,U,6),1:"")_U
;-- high level psych class
S Y=Y_$S($P(N300,U,7):$P(N300,U,7),1:"")_U
Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTAPA1 2455 printed Dec 13, 2024@02:51:38 Page 2
DGPTAPA1 ;ALB/MTC - PTF A/P ARCHIVE UTILITY ; 10-19-92
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
ARINT ;
+1 DO ARMAIN
DO AR401^DGPTAPA2
DO AR601^DGPTAPA2
DO AR501^DGPTAPA3
DO AR535^DGPTAPA3
+2 QUIT
+3 ;
ARMAIN ;-- This function will load the array containing the
+1 ; PTF detailed information.
+2 ; INPUT : DGPTF - Valid PTF entry
+3 ; DGTMP - IEN of the template used
+4 ;
+5 NEW I,X,Y,DG70,NUMREC,SEQ,OSEQ,REF
+6 ;--
+7 SET OSEQ=$GET(^DGP(45.62,DGTMP,100,0))
if OSEQ']""
QUIT
+8 SET SEQ=$PIECE(OSEQ,U,3)
SET REF="^DGP(45.62,"_DGTMP_",100)"
+9 SET DG70=$GET(^DGPT(DGPTF,70))
+10 ;
+11 ;--patient name (2)
+12 SET Y=DGPTF_U_$PIECE(^DPT(+^DGPT(DGPTF,0),0),U)
+13 ;--admission date (3)
+14 SET Y=Y_U_$PIECE(^DGPT(DGPTF,0),U,2)
+15 ;--discharge date (4)
+16 SET Y=Y_U_$SELECT(+DG70:+DG70,1:"")
+17 ;--discharge specilaty (5)
+18 SET Y=Y_U_$SELECT($PIECE(DG70,U,2):$PIECE(^DIC(42.4,$PIECE(DG70,U,2),0),U),1:"")
SET X=$PIECE(DG70,U,3)
+19 ;--type of disposition (6)
+20 SET Y=Y_U_$SELECT(X:$PIECE($PIECE($PIECE(^DD(45,72,0),U,3),";",X),":",2),1:"")
+21 SET X=$PIECE(DG70,U,14)
+22 ;--discharge status (7)
+23 SET Y=Y_U_$SELECT(X:$PIECE($PIECE($PIECE(^DD(45,72.1,0),U,3),";",X),":",2),1:"")
+24 SET X=$PIECE(DG70,U,4)
+25 ;--outpatient treatment (8)
+26 SET Y=Y_U_$SELECT(X=1:"YES",1:"NO")
+27 ;-- ASIH days (9)
+28 SET Y=Y_U_$SELECT($PIECE(DG70,U,8)]"":$PIECE(DG70,U,8),1:"")
+29 SET X=$PIECE(DG70,U,9)
+30 ;-- C&P Status (10)
+31 SET Y=Y_U_$SELECT(X:$PIECE($PIECE($PIECE(^DD(45,78,0),U,3),";",X),":",2),1:"")
+32 ;-- VA Auspices (11)
+33 SET Y=Y_U_$SELECT($PIECE(DG70,U,5)=1:"YES",1:"NO")
+34 ;-- income (12)
+35 SET DGINC=$PIECE($GET(^DGPT(DGPTF,101)),U,7)
+36 SET Y=Y_U_$SELECT(DGINC]"":DGINC,1:"")
+37 ;
+38 ;-- check for ICD codes (13-22)
+39 FOR I=10,15:1:24
Begin DoDot:1
+40 SET Y=Y_U_$SELECT($PIECE(DG70,U,I):$PIECE(^ICD9($PIECE(DG70,U,I),0),U),1:"")
End DoDot:1
+41 ;
+42 ;-- check for 300 node information (23-28)
+43 SET X=$GET(^DGPT(DGPTF,300))
+44 SET Y=Y_U_$$AR300(X)
SET SEQ=SEQ+1
SET @REF@(SEQ,0)=Y
+45 ;
+46 ;-- update
+47 SET $PIECE(^DGP(45.62,DGTMP,100,0),U,3,4)=SEQ_U_SEQ
+48 ;
+49 QUIT
+50 ;
AR300(N300) ;-- load 300 node information
+1 ; INPUT N300 - Contains 300 node
+2 ; OUTPUT - Load display array
+3 ;
+4 NEW Y,X
+5 ;-- suicide indicator
+6 SET Y=$SELECT($PIECE(N300,U,2)=1:"Attempted",$PIECE(N300,U,2)=2:"Accomplished",1:"")_U
+7 ;-- legionnaire's
+8 SET Y=Y_$SELECT($PIECE(N300,U,3)=1:"YES",1:"NO")_U
+9 ;-- abused substance
+10 SET Y=Y_$SELECT($PIECE(N300,U,4):$PIECE($GET(^DIC(45.61,$PIECE(N300,U,4),0)),U),1:"")_U
+11 ;-- psych class severity
+12 IF $PIECE(N300,U,5)]""
Begin DoDot:1
+13 SET X=$PIECE(N300,U,5)
+14 SET Y=Y_$SELECT(X]"":$PIECE($PIECE($PIECE(^DD(45.02,300.05,0),U,3),";",X),":",2),1:"")_U
End DoDot:1
+15 IF $PIECE(N300,U,5)=""
SET Y=Y_U
+16 ;-- current func assessment
+17 SET Y=Y_$SELECT($PIECE(N300,U,6):$PIECE(N300,U,6),1:"")_U
+18 ;-- high level psych class
+19 SET Y=Y_$SELECT($PIECE(N300,U,7):$PIECE(N300,U,7),1:"")_U
+20 QUIT Y
+21 ;
