- 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
