Routine: DGPTAPA1

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

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

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  Feb 19, 2025@00:17:39                                                                                                                                                                                                    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      ;

DGPTAPA1.m