AMHLETN.m

AMHLETN ; IHS/CMI/LAB - DISPLAY/EDIT TREATMENT NOTES ;

 ;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18

 ;

 ;

 ;

PRTTXT ; GENERALIZED TEXT PRINTER

 S AMHLETP("DLT")=1,AMHLETP("ILN")=80-AMHLETP("ICL")-1

 F AMHLETP("Q")=0:0 S:AMHLETP("NRQ")]""&(($L(AMHLETP("NRQ"))+$L(AMHLETP("TXT"))+2)<255) AMHLETP("TXT")=$S(AMHLETP("TXT")]"":AMHLETP("TXT")_"; ",1:"")_AMHLETP("NRQ"),AMHLETP("NRQ")="" Q:AMHLETP("TXT")=""  D PRTTXT2

 K AMHLETP("ILN"),AMHLETP("DLT"),AMHLETP("F"),AMHLETP("C"),AMHLETP("TXT"),AMHTDOO

 Q

PRTTXT2 D GETFRAG W ?AMHLETP("ICL") W AMHLETP("F"),! S AMHLETP("ICL")=AMHLETP("ICL")+AMHLETP("DLT"),AMHLETP("ILN")=AMHLETP("ILN")-AMHLETP("DLT"),AMHLETP("DLT")=0

 Q

GETFRAG I $L(AMHLETP("TXT"))<AMHLETP("ILN") S AMHLETP("F")=AMHLETP("TXT"),AMHLETP("TXT")="" Q

 F AMHLETP("C")=AMHLETP("ILN"):-1:1 Q:$E(AMHLETP("TXT"),AMHLETP("C"))=" "

 S AMHLETP("F")=$E(AMHLETP("TXT"),1,AMHLETP("C")-1),AMHLETP("TXT")=$E(AMHLETP("TXT"),AMHLETP("C")+1,255)

 Q

 ;

GETNUM(AMHPROBN) ;EP - get next TP NUMBER

 NEW %,Y,X,AMHLETP

 S (%,X)=0 F  S %=$O(^AMHPTP("AE",AMHPROBN,%)) Q:%'=+%  S X=%

 S AMHLETP("NUM")=X+1

 Q AMHLETP("NUM")

DISP ;EP - display current Treatment plans for this problem

 ;AMHLETP("PROB IEN")=PROBLEM IEN

 ;NO paging is done, just scroll

 Q:'$G(AMHLETP("PROB IEN"))

 S AMHLETP("PROB REC")=^AMHPPROB(AMHLETP("PROB IEN"),0)

 W !!,"Problem #",+$P(AMHLETP("PROB REC"),U,7),?17,"Problem Diagnosis: ",$P(^AMHPROB($P(AMHLETP("PROB REC"),U),0),U),?45,"Patient: ",$E($P(^DPT($P(AMHLETP("PROB REC"),U,2),0),U),1,25)

 W !,"Provider Narrative: " S AMHLETP("NRQ")=$$GET1^DIQ(9002011.51,AMHLETP("PROB IEN"),.05),AMHLETP("ICL")=21,AMHLETP("TXT")="" D PRTTXT

 I $O(^AMHPTP("AE",AMHLETP("PROB IEN"),"")) W !,"TREATMENT NOTES:",!

 ;I '$O(^AMHPTP("AE",AMHLETP("PROB IEN"),"")) W !!,"No Treatment Plans recorded for this problem.",! K AMHLETP Q

 NEW %

 S %=0 F  S %=$O(^AMHPTP("AE",AMHLETP("PROB IEN"),%)) Q:%'=+%  D

 .S AMHLETP("TP IEN")=$O(^AMHPTP("AE",AMHLETP("PROB IEN"),%,""))

 .Q:'AMHLETP("TP IEN")

 .S AMHLETP("TN")=^AMHPTP(AMHLETP("TP IEN"),0)

 .S AMHLETP("DON")=$P(AMHLETP("TN"),U,5) I AMHLETP("DON")]"" S AMHLETP("DON")=$E(AMHLETP("DON"),4,5)_"/"_$E(AMHLETP("DON"),6,7)_"/"_$E(AMHLETP("DON"),2,3)

 .S AMHLETP("PT")=$P(AMHLETP("TN"),U,7) S AMHLETP("PT")=$S(AMHLETP("PT")=1:"STP",AMHLETP("PT")=2:"LTP",1:"   ")

 .S AMHLETP("AUTH")=$P(AMHLETP("TN"),U,6) I AMHLETP("AUTH")]"" S AMHLETP("AUTH")=$P(^VA(200,AMHLETP("AUTH"),0),U,2)

 .W ?2,+AMHLETP("TN"),?5,AMHLETP("PT"),?10,AMHLETP("DON"),?19,AMHLETP("AUTH")

 .S AMHLETP("NRQ")=$P(AMHLETP("TN"),U,4),AMHLETP("ICL")=23,AMHLETP("TXT")="" D PRTTXT

 .Q

 K AMHLETP,Y

 Q

 ;

DEL ;EP - called from template to delete all TP's for a PROBLEM

 ;AMHPDFN - problem ien

 D EN^XBNEW("EN1^AMHLETN","AMHPDFN;AUPN*")

 Q

EN1 ;EP - called from xbnew

 S AMHX=0 F  S AMHX=$O(^AMHPTP("AD",AMHPDFN,AMHX)) Q:AMHX'=+AMHX  S DA=AMHX,DIK="^AMHPTP(" D ^DIK

 K AMHX

 Q

AMHLETN   ; IHS/CMI/LAB - DISPLAY/EDIT TREATMENT NOTES ;

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18

 +2       ;

 +3       ;

 +4       ;

PRTTXT    ; GENERALIZED TEXT PRINTER

 +1        SET AMHLETP("DLT")=1

           SET AMHLETP("ILN")=80-AMHLETP("ICL")-1

 +2        FOR AMHLETP("Q")=0:0

               IF AMHLETP("NRQ")]""&(($LENGTH(AMHLETP("NRQ"))+$LENGTH(AMHLETP("TXT"))+2)<255)

                   SET AMHLETP("TXT")=$SELECT(AMHLETP("TXT")]"":AMHLETP("TXT")_"; ",1:"")_AMHLETP("NRQ")

                   SET AMHLETP("NRQ")=""

               IF AMHLETP("TXT")=""

                   QUIT 

               DO PRTTXT2

 +3        KILL AMHLETP("ILN"),AMHLETP("DLT"),AMHLETP("F"),AMHLETP("C"),AMHLETP("TXT"),AMHTDOO

 +4        QUIT 

PRTTXT2    DO GETFRAG

           WRITE ?AMHLETP("ICL")

           WRITE AMHLETP("F"),!

           SET AMHLETP("ICL")=AMHLETP("ICL")+AMHLETP("DLT")

           SET AMHLETP("ILN")=AMHLETP("ILN")-AMHLETP("DLT")

           SET AMHLETP("DLT")=0

 +1        QUIT 

GETFRAG    IF $LENGTH(AMHLETP("TXT"))<AMHLETP("ILN")

               SET AMHLETP("F")=AMHLETP("TXT")

               SET AMHLETP("TXT")=""

               QUIT 

 +1        FOR AMHLETP("C")=AMHLETP("ILN"):-1:1

               IF $EXTRACT(AMHLETP("TXT"),AMHLETP("C"))=" "

                   QUIT 

 +2        SET AMHLETP("F")=$EXTRACT(AMHLETP("TXT"),1,AMHLETP("C")-1)

           SET AMHLETP("TXT")=$EXTRACT(AMHLETP("TXT"),AMHLETP("C")+1,255)

 +3        QUIT 

 +4       ;

GETNUM(AMHPROBN) ;EP - get next TP NUMBER

 +1        NEW %,Y,X,AMHLETP

 +2        SET (%,X)=0

           FOR 

               SET %=$ORDER(^AMHPTP("AE",AMHPROBN,%))

               IF %'=+%

                   QUIT 

               SET X=%

 +3        SET AMHLETP("NUM")=X+1

 +4        QUIT AMHLETP("NUM")

DISP      ;EP - display current Treatment plans for this problem

 +1       ;AMHLETP("PROB IEN")=PROBLEM IEN

 +2       ;NO paging is done, just scroll

 +3        IF '$GET(AMHLETP("PROB IEN"))

               QUIT 

 +4        SET AMHLETP("PROB REC")=^AMHPPROB(AMHLETP("PROB IEN"),0)

 +5        WRITE !!,"Problem #",+$PIECE(AMHLETP("PROB REC"),U,7),?17,"Problem Diagnosis: ",$PIECE(^AMHPROB($PIECE(AMHLETP("PROB REC"),U),0),U),?45,"Patient: ",$EXTRACT($PIECE(^DPT($PIECE(AMHLETP("PROB REC"),U,2),0),U),1,25)

 +6        WRITE !,"Provider Narrative: "

           SET AMHLETP("NRQ")=$$GET1^DIQ(9002011.51,AMHLETP("PROB IEN"),.05)

           SET AMHLETP("ICL")=21

           SET AMHLETP("TXT")=""

           DO PRTTXT

 +7        IF $ORDER(^AMHPTP("AE",AMHLETP("PROB IEN"),""))

               WRITE !,"TREATMENT NOTES:",!

 +8       ;I '$O(^AMHPTP("AE",AMHLETP("PROB IEN"),"")) W !!,"No Treatment Plans recorded for this problem.",! K AMHLETP Q

 +9        NEW %

 +10       SET %=0

           FOR 

               SET %=$ORDER(^AMHPTP("AE",AMHLETP("PROB IEN"),%))

               IF %'=+%

                   QUIT 

               Begin DoDot:1

 +11               SET AMHLETP("TP IEN")=$ORDER(^AMHPTP("AE",AMHLETP("PROB IEN"),%,""))

 +12               IF 'AMHLETP("TP IEN")

                       QUIT 

 +13               SET AMHLETP("TN")=^AMHPTP(AMHLETP("TP IEN"),0)

 +14               SET AMHLETP("DON")=$PIECE(AMHLETP("TN"),U,5)

                   IF AMHLETP("DON")]""

                       SET AMHLETP("DON")=$EXTRACT(AMHLETP("DON"),4,5)_"/"_$EXTRACT(AMHLETP("DON"),6,7)_"/"_$EXTRACT(AMHLETP("DON"),2,3)

 +15               SET AMHLETP("PT")=$PIECE(AMHLETP("TN"),U,7)

                   SET AMHLETP("PT")=$SELECT(AMHLETP("PT")=1:"STP",AMHLETP("PT")=2:"LTP",1:"   ")

 +16               SET AMHLETP("AUTH")=$PIECE(AMHLETP("TN"),U,6)

                   IF AMHLETP("AUTH")]""

                       SET AMHLETP("AUTH")=$PIECE(^VA(200,AMHLETP("AUTH"),0),U,2)

 +17               WRITE ?2,+AMHLETP("TN"),?5,AMHLETP("PT"),?10,AMHLETP("DON"),?19,AMHLETP("AUTH")

 +18               SET AMHLETP("NRQ")=$PIECE(AMHLETP("TN"),U,4)

                   SET AMHLETP("ICL")=23

                   SET AMHLETP("TXT")=""

                   DO PRTTXT

 +19               QUIT 

               End DoDot:1

 +20       KILL AMHLETP,Y

 +21       QUIT 

 +22      ;

DEL       ;EP - called from template to delete all TP's for a PROBLEM

 +1       ;AMHPDFN - problem ien

 +2        DO EN^XBNEW("EN1^AMHLETN","AMHPDFN;AUPN*")

 +3        QUIT 

EN1       ;EP - called from xbnew

 +1        SET AMHX=0

           FOR 

               SET AMHX=$ORDER(^AMHPTP("AD",AMHPDFN,AMHX))

               IF AMHX'=+AMHX

                   QUIT 

               SET DA=AMHX

               SET DIK="^AMHPTP("

               DO ^DIK

 +2        KILL AMHX

 +3        QUIT