ACHSDFL ; IHS/ITSC/PMF - DEFERRED SERVICES LETTER (1/2) ;JUL 10, 2008
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,23**;JUN 11,2001;Build 43
;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES & CHANGED ZTSK TO ZTQUEQUED
;ACHS*3.1*18 4/1/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
;
;IHS/SET/JVK ACHS*3.1*6 3/24/2003 SET THE LETTER WITH TO 75
;S DIWL=5,DIWR=$S($G(IOM):IOM,1:75),DIWF="W"
S DIWL=5,DIWR=75,DIWF="W"
PAT ; --- Select Deferred Service
W !!
K DIC,A,ACHSA
S DIC("S")="I $E($P($G(^(0)),U))'=""#"",$P($G(^(0)),U,14)'=""Y"""
S DIC("W")="W "" ""_$S($P($G(^(0)),U,5)=""Y"":$P($G(^DPT($P($G(^(0)),U,6),0)),U),$P($G(^(0)),U,5)=""N"":$P($G(^(0)),U,7),1:""UNDEFINED"")"
S DIC="^ACHSDEF("_DUZ(2)_",""D"","
S DIC(0)="AEMQZ"
;{ABK,3/31/10}S DIC("A")="Enter DEFERRED SERVICES NUMBER or PATIENT'S NAME: "
S DIC("A")="Enter UNMET NEEDS NUMBER or PATIENT'S NAME: "
S DA(1)=DUZ(2)
D ^DIC
K DIC
I +Y="" D END1 Q
I +Y<1 D END1 Q
;
S ACHSA=+Y
G P0:'$P(Y(0),U,6)
G P0:'$D(^DPT($P(Y(0),U,6),0))
S DFN=$P(Y(0),U,6)
G P1
;
P0 ;
S X=$P(Y(0),U,7)
I '$L(X) D NAMERR G PAT
P1 ;
;{ABK,3/31/10}W !!,"You wish to print deferred services letter ",$P(Y(0),U),!!
W !!,"You wish to print unmet needs letter ",$P(Y(0),U),!!
G P2:'$D(DFN)
W ?5,$P($G(^DPT(DFN,0)),U)
S X=$G(^DPT(DFN,.11))
W !?5,$P(X,U),!?5,$P(X,U,4)
S Y=$P(X,U,5)
I Y]"",$D(^DIC(5,Y,0)) W ", ",$P($G(^DIC(5,Y,0)),U,2)
W " ",$P(X,U,6),!!
G P3
P2 ;
S X=$G(^ACHSDEF(DUZ(2),"D",ACHSA,0))
W ?5,$P(X,U,7),!?5,$P(X,U,8),!?5,$P(X,U,9)
S Y=$P(X,U,10)
I Y]"",$D(^DIC(5,Y,0)) W ", ",$P($G(^DIC(5,Y,0)),U,2)
W " ",$P(X,U,11),!!
P3 ;
S %=$$DIR^ACHS("Y","Is this correct","YES","","",2)
I $D(DTOUT)!$D(DUOUT) D END Q
G PAT:'%
DEV ;
W !!
S %ZIS="OPQ"
D ^%ZIS
I POP D HOME^%ZIS D END Q
G:'$D(IO("Q")) START^ACHSDFL1
K IO("Q")
I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
;{ABK, 3/31/10}S ZTRTN="START^ACHSDFL1",ZTDESC="CHS Deferred Services Letter",ZTSAVE("ACHSA")=""
S ZTRTN="START^ACHSDFL1",ZTDESC="CHS Unmet Needs Letter",ZTSAVE("ACHSA")=""
D ^%ZTLOAD
;3.1*14 12.4.2007 IHS/OIT/FCJ
;G:'$D(ZTSK) DEV
G:'$D(ZTQUEQUED) DEV
Q
;
NAMERR ;
W !!,*7,"No valid PATIENT NAME in this file.",!,"No letter may be printed until a valid patient is entered.",!!
Q
;
END ;EP
W !!!
I $D(ACHDONE) F I=1:1:4 W "*** OFFICE COPY *** "
I $$DF^ACHS(0,14)="Y" F I=1:1:4 W "DOCUMENT CANCELLED *"
;IHS/SET/JVK ACHS*3.1*6 3/24/2003 SET THE LETTER WIDTH TO 75 AND FIX PG NUMBERING VAR ACHSPG
;I $D(ACHDONE) K ACHDONE D RTRN^ACHS W @IOF S ACHDPG=1,DIWL=5,DIWR=$S($G(IOM):IOM,1:75),DIWF="W" G DOC^ACHSDFL1
I $D(ACHDONE) K ACHDONE D RTRN^ACHS W @IOF S ACHSPG=1,DIWL=5,DIWR=75,DIWF="W" G DOC^ACHSDFL1
I IO(0)=IO D RTRN^ACHS
K ACHSA,ACHDST,ACHDPAT,ACHDX,ACHSDDX
END1 ;
D ^%ZISC
Q
;
TYPE ;EP
;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES TO FOR LOOP
I $D(^ACHSDEF(DUZ(2),"D",ACHSA,200)) S ACHDX=0 F S ACHDX=$O(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX)) Q:+ACHDX=0 D
. S ACHSDDX=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX,0)),U)
. I $P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX,0)),U,2)]"" W !,?DIWL+10,$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX,0)),U,2),!
. E W !,?DIWL+10 I ACHSDDX,$P($$ICDDX^ICDEX(ACHSDDX),U,6) W $P(^ICM($P($$ICDDX^ICDEX(ACHSDDX),U,6),0),U) ;ACHS*3.1*23 ICD-10
. ;E W !,?DIWL+10 I ACHSDDX,$P($$ICDDX^ICDCODE(ACHSDDX),U,6) W $P(^ICM($P($$ICDDX^ICDCODE(ACHSDDX),U,6),0),U) ;ACHS*3.1*23 ICD-10
. ;E W !,?DIWL+10,$P($G(^ICD9($P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX,0)),U),0)),U,3),!
;
I $D(^ACHSDEF(DUZ(2),"D",ACHSA,300)) S ACHDX=0 F S ACHDX=$O(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX)) Q:+ACHDX=0 D
. I $P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX,0)),U,2)]"" W !,?DIWL+10,$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX,0)),U,2)
. ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
. ;E W !,?DIWL+10,$P($G(^ICPT($P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX,0)),U),0)),U),!
. E W !,?DIWL+10,$P($$CPT^ICPTCOD($P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX,0)),U)),U,2),!
;
W !
Q
;
ACHSDFL ; IHS/ITSC/PMF - DEFERRED SERVICES LETTER (1/2) ;JUL 10, 2008
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,23**;JUN 11,2001;Build 43
+2 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES & CHANGED ZTSK TO ZTQUEQUED
+3 ;ACHS*3.1*18 4/1/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
+4 ;
+5 ;IHS/SET/JVK ACHS*3.1*6 3/24/2003 SET THE LETTER WITH TO 75
+6 ;S DIWL=5,DIWR=$S($G(IOM):IOM,1:75),DIWF="W"
+7 SET DIWL=5
SET DIWR=75
SET DIWF="W"
PAT ; --- Select Deferred Service
+1 WRITE !!
+2 KILL DIC,A,ACHSA
+3 SET DIC("S")="I $E($P($G(^(0)),U))'=""#"",$P($G(^(0)),U,14)'=""Y"""
+4 SET DIC("W")="W "" ""_$S($P($G(^(0)),U,5)=""Y"":$P($G(^DPT($P($G(^(0)),U,6),0)),U),$P($G(^(0)),U,5)=""N"":$P($G(^(0)),U,7),1:""UNDEFINED"")"
+5 SET DIC="^ACHSDEF("_DUZ(2)_",""D"","
+6 SET DIC(0)="AEMQZ"
+7 ;{ABK,3/31/10}S DIC("A")="Enter DEFERRED SERVICES NUMBER or PATIENT'S NAME: "
+8 SET DIC("A")="Enter UNMET NEEDS NUMBER or PATIENT'S NAME: "
+9 SET DA(1)=DUZ(2)
+10 DO ^DIC
+11 KILL DIC
+12 IF +Y=""
DO END1
QUIT
+13 IF +Y<1
DO END1
QUIT
+14 ;
+15 SET ACHSA=+Y
+16 IF '$PIECE(Y(0),U,6)
GOTO P0
+17 IF '$DATA(^DPT($PIECE(Y(0),U,6),0))
GOTO P0
+18 SET DFN=$PIECE(Y(0),U,6)
+19 GOTO P1
+20 ;
P0 ;
+1 SET X=$PIECE(Y(0),U,7)
+2 IF '$LENGTH(X)
DO NAMERR
GOTO PAT
P1 ;
+1 ;{ABK,3/31/10}W !!,"You wish to print deferred services letter ",$P(Y(0),U),!!
+2 WRITE !!,"You wish to print unmet needs letter ",$PIECE(Y(0),U),!!
+3 IF '$DATA(DFN)
GOTO P2
+4 WRITE ?5,$PIECE($GET(^DPT(DFN,0)),U)
+5 SET X=$GET(^DPT(DFN,.11))
+6 WRITE !?5,$PIECE(X,U),!?5,$PIECE(X,U,4)
+7 SET Y=$PIECE(X,U,5)
+8 IF Y]""
IF $DATA(^DIC(5,Y,0))
WRITE ", ",$PIECE($GET(^DIC(5,Y,0)),U,2)
+9 WRITE " ",$PIECE(X,U,6),!!
+10 GOTO P3
P2 ;
+1 SET X=$GET(^ACHSDEF(DUZ(2),"D",ACHSA,0))
+2 WRITE ?5,$PIECE(X,U,7),!?5,$PIECE(X,U,8),!?5,$PIECE(X,U,9)
+3 SET Y=$PIECE(X,U,10)
+4 IF Y]""
IF $DATA(^DIC(5,Y,0))
WRITE ", ",$PIECE($GET(^DIC(5,Y,0)),U,2)
+5 WRITE " ",$PIECE(X,U,11),!!
P3 ;
+1 SET %=$$DIR^ACHS("Y","Is this correct","YES","","",2)
+2 IF $DATA(DTOUT)!$DATA(DUOUT)
DO END
QUIT
+3 IF '%
GOTO PAT
DEV ;
+1 WRITE !!
+2 SET %ZIS="OPQ"
+3 DO ^%ZIS
+4 IF POP
DO HOME^%ZIS
DO END
QUIT
+5 IF '$DATA(IO("Q"))
GOTO START^ACHSDFL1
+6 KILL IO("Q")
+7 IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+8 ;{ABK, 3/31/10}S ZTRTN="START^ACHSDFL1",ZTDESC="CHS Deferred Services Letter",ZTSAVE("ACHSA")=""
+9 SET ZTRTN="START^ACHSDFL1"
SET ZTDESC="CHS Unmet Needs Letter"
SET ZTSAVE("ACHSA")=""
+10 DO ^%ZTLOAD
+11 ;3.1*14 12.4.2007 IHS/OIT/FCJ
+12 ;G:'$D(ZTSK) DEV
+13 IF '$DATA(ZTQUEQUED)
GOTO DEV
+14 QUIT
+15 ;
NAMERR ;
+1 WRITE !!,*7,"No valid PATIENT NAME in this file.",!,"No letter may be printed until a valid patient is entered.",!!
+2 QUIT
+3 ;
END ;EP
+1 WRITE !!!
+2 IF $DATA(ACHDONE)
FOR I=1:1:4
WRITE "*** OFFICE COPY *** "
+3 IF $$DF^ACHS(0,14)="Y"
FOR I=1:1:4
WRITE "DOCUMENT CANCELLED *"
+4 ;IHS/SET/JVK ACHS*3.1*6 3/24/2003 SET THE LETTER WIDTH TO 75 AND FIX PG NUMBERING VAR ACHSPG
+5 ;I $D(ACHDONE) K ACHDONE D RTRN^ACHS W @IOF S ACHDPG=1,DIWL=5,DIWR=$S($G(IOM):IOM,1:75),DIWF="W" G DOC^ACHSDFL1
+6 IF $DATA(ACHDONE)
KILL ACHDONE
DO RTRN^ACHS
WRITE @IOF
SET ACHSPG=1
SET DIWL=5
SET DIWR=75
SET DIWF="W"
GOTO DOC^ACHSDFL1
+7 IF IO(0)=IO
DO RTRN^ACHS
+8 KILL ACHSA,ACHDST,ACHDPAT,ACHDX,ACHSDDX
END1 ;
+1 DO ^%ZISC
+2 QUIT
+3 ;
TYPE ;EP
+1 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES TO FOR LOOP
+2 IF $DATA(^ACHSDEF(DUZ(2),"D",ACHSA,200))
SET ACHDX=0
FOR
SET ACHDX=$ORDER(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX))
IF +ACHDX=0
QUIT
Begin DoDot:1
+3 SET ACHSDDX=$PIECE($GET(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX,0)),U)
+4 IF $PIECE($GET(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX,0)),U,2)]""
WRITE !,?DIWL+10,$PIECE($GET(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX,0)),U,2),!
+5 ;ACHS*3.1*23 ICD-10
IF '$TEST
WRITE !,?DIWL+10
IF ACHSDDX
IF $PIECE($$ICDDX^ICDEX(ACHSDDX),U,6)
WRITE $PIECE(^ICM($PIECE($$ICDDX^ICDEX(ACHSDDX),U,6),0),U)
+6 ;E W !,?DIWL+10 I ACHSDDX,$P($$ICDDX^ICDCODE(ACHSDDX),U,6) W $P(^ICM($P($$ICDDX^ICDCODE(ACHSDDX),U,6),0),U) ;ACHS*3.1*23 ICD-10
+7 ;E W !,?DIWL+10,$P($G(^ICD9($P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX,0)),U),0)),U,3),!
End DoDot:1
+8 ;
+9 IF $DATA(^ACHSDEF(DUZ(2),"D",ACHSA,300))
SET ACHDX=0
FOR
SET ACHDX=$ORDER(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX))
IF +ACHDX=0
QUIT
Begin DoDot:1
+10 IF $PIECE($GET(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX,0)),U,2)]""
WRITE !,?DIWL+10,$PIECE($GET(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX,0)),U,2)
+11 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
+12 ;E W !,?DIWL+10,$P($G(^ICPT($P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX,0)),U),0)),U),!
+13 IF '$TEST
WRITE !,?DIWL+10,$PIECE($$CPT^ICPTCOD($PIECE($GET(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX,0)),U)),U,2),!
End DoDot:1
+14 ;
+15 WRITE !
+16 QUIT
+17 ;
