BSDFORM ; IHS/ANMC/LJF - PRINTS HS & OTHER FORMS ; [ 04/08/2004 2:26 PM ]
;;5.3;PIMS;**1017,1019**;APR 26, 2002;Build 3
;
HS(APCHSPAT,APCHSTYP) ;EP; prints health summary
; calls published entry point EN^APCHS
NEW DFN,SDATE,ORDER,SDCNT,SDSTART,SDSTOP,DIV,SDX,SDREP
NEW SORT,TERM,CNT,ZZZ
I $Y>5 W @IOF
;
;IHS/ITSC/LJF 4/8/2004 if HS set to print but no type defined . . .
;I 'APCHSTYP S APCHSTYP=$O(^APCHSCTL("B","ADULT REGULAR",0)) Q:'APCHSTYP ;IHS/ITSC/LJF 1/2/2004
I 'APCHSTYP D
. NEW AGE,X,LIMIT
. S AGE=$$GET1^DIQ(APCHSPAT,.033) ;patient's age
. S X=$$GET1^DIQ(9009020.1,+$$GET1^DIQ(43,1,12,"I"),.05) ;min age for adult
. S LIMIT=$S($G(X):X,1:15)
. S APCHSTYP=$S(AGE<LIMIT:$O(^APCHSCTL("B","PEDIATRIC",0)),1:$O(^APCHSCTL("B","ADULT REGULAR",0)))
;IHS/ITSC/LJF 4/8/2004 end of changes
;
D EN^APCHS
K AUPNPAT,AUPNDOB,AUPNDOD,AUPNSEX,DIC
K APCHSPDN,APCHSTAT,APCHSVTP,APCHSNDF,APCHSPRB
Q
;
MP(DFN) ;EP; prints med profile
NEW SDATE,ORDER,SDCNT,SDSTART,SDSTOP,DIV,SDX,SDREP
NEW FN,DA,D0,PLS,PSRT,PSLC,PSZCHN,ST,ST0,PSODTCT
NEW SORT,TERM,CNT,ZZZ
K ^UTILITY($J)
NEW HDR S HDR="ISSUE DATE" ;IHS/ITSC/LJF 1/14/2004 varialbe needed by Phr v7
S (FN,DA,D0)=DFN,PSRT="DATE",X=""
S X1=DT,X2=-365 D C^%DTC S PSODTCT=X
S X="PSOP" X ^%ZOSF("TEST") I $T S PLS="S" U IO D P^PSOP Q
S X="PSP" X ^%ZOSF("TEST") I $T S PLS=1 U IO D P^PSP
Q
;
AIU(DFN,DIV) ; EP; prints address/insurance update
NEW SDATE,ORDER,SDCNT,SDSTART,SDSTOP,SDX,SDREP
NEW BSDX,BSDY,BSDFORM
NEW SORT,TERM,CNT
S BSDFORM=1 ;set to prevent device closure in BSDAIU
S BSDX=$$GET1^DIQ(9000001,DFN,.03,"I") ;last reg update
S BSDY=$$GET1^DIQ(9009020.2,$$DIV^BSDU,.08) ;waiting days
;IHS/ITSC/WAR 3/16/04 chg greater than/less than symbol
;I $$FMADD^XLFDT(BSDX,BSDY)<DT Q ;not time yet
I $$FMADD^XLFDT(BSDX,BSDY)>DT Q ;not time yet
I $Y>5 W @IOF
D BEGIN^BSDAIU
Q
;
APRO(SC,DFN,CLDT) ;EP; calls pharmacy to print action profile
NEW SDATE,ORDER,SDCNT,SDSTART,SDSTOP,DIV,SDX,SDREP
NEW FN,DA,D0,PLS,PSRT,PSLC,PSZCHN,ST,ST0,PSODTCT
NEW BSDATT,BSDATTO,BSDATTC,BSDIOM
NEW SORT,TERM,CNT,ZZZ
;
; set variables needed by pharmacy routine
K ^TMP($J)
S CLINICX=$P(^SC(+SC,0),U)
S PAGE=1,D1=CLDT,PSTYPE=1
S PSDAYS=90,X1=DT,X2=-PSDAYS D C^%DTC S (PSDATE,PSDAY)=X
S LINE=$$REPEAT^XLFSTR("-",132)
;S BSDATT=$P(^DG(40.8,1,"IHS"),U,16) ;6/28/2002 per Linda (LJF11)
S BSDATT=$$GET1^DIQ(9009020.2,+$$DIV^BSDU,.13,"I") Q:'BSDATT ;APRO terminal type;IHS/ANMC/LJF 6/26/2002
S BSDATTO=$G(^%ZIS(2,BSDATT,2)) ;IHS/ITSC/LJF 1/2/2004 added $G
S BSDATTC=$G(^%ZIS(2,BSDATT,3)) ;IHS/ITSC/LJF 1/2/2004 added $G
;IHS/ITSC/WAR 7/22/03 added next line to identify which pharmacy in ^PS
;S PSOSITE=$O(^PS(59,"C",DUZ(2),0))
S PSOSITE=$O(^PS(59,"D",DUZ(2),0)) ;ihs/cmi/maw 03/01/2012 notified by Chris Saddler that this is now "D" for the station number
X BSDATTO S BSDIOM=IOM,X=132 X ^%ZOSF("RM")
D HD^PSOSD2,PAT^PSOSD,RXPAD^PSOSD1:PSTYPE
W:'$G(PSTYPE)&('$D(^TMP("PSOD",$J))) @IOF
D ENSTUFF^PSODACT
X BSDATTC S X=BSDIOM X ^%ZOSF("RM")
K CLINICX,PAGE,PSTYPE,PSDAYS,PSDATE,PSDAY,PSDT,PSNAME
K VAPA,VAIN,VAEL,VAERR,PSOBAR2,PSOBAR3,PSOBAR4,PSOPRINT,PSSN,RXCNT
K LN,LINE,HRCN,FN,ELN,CNT,ADDRFL,VA,PSDOB
Q
BSDFORM ; IHS/ANMC/LJF - PRINTS HS & OTHER FORMS ; [ 04/08/2004 2:26 PM ]
+1 ;;5.3;PIMS;**1017,1019**;APR 26, 2002;Build 3
+2 ;
HS(APCHSPAT,APCHSTYP) ;EP; prints health summary
+1 ; calls published entry point EN^APCHS
+2 NEW DFN,SDATE,ORDER,SDCNT,SDSTART,SDSTOP,DIV,SDX,SDREP
+3 NEW SORT,TERM,CNT,ZZZ
+4 IF $Y>5
WRITE @IOF
+5 ;
+6 ;IHS/ITSC/LJF 4/8/2004 if HS set to print but no type defined . . .
+7 ;I 'APCHSTYP S APCHSTYP=$O(^APCHSCTL("B","ADULT REGULAR",0)) Q:'APCHSTYP ;IHS/ITSC/LJF 1/2/2004
+8 IF 'APCHSTYP
Begin DoDot:1
+9 NEW AGE,X,LIMIT
+10 ;patient's age
SET AGE=$$GET1^DIQ(APCHSPAT,.033)
+11 ;min age for adult
SET X=$$GET1^DIQ(9009020.1,+$$GET1^DIQ(43,1,12,"I"),.05)
+12 SET LIMIT=$SELECT($GET(X):X,1:15)
+13 SET APCHSTYP=$SELECT(AGE<LIMIT:$ORDER(^APCHSCTL("B","PEDIATRIC",0)),1:$ORDER(^APCHSCTL("B","ADULT REGULAR",0)))
End DoDot:1
+14 ;IHS/ITSC/LJF 4/8/2004 end of changes
+15 ;
+16 DO EN^APCHS
+17 KILL AUPNPAT,AUPNDOB,AUPNDOD,AUPNSEX,DIC
+18 KILL APCHSPDN,APCHSTAT,APCHSVTP,APCHSNDF,APCHSPRB
+19 QUIT
+20 ;
MP(DFN) ;EP; prints med profile
+1 NEW SDATE,ORDER,SDCNT,SDSTART,SDSTOP,DIV,SDX,SDREP
+2 NEW FN,DA,D0,PLS,PSRT,PSLC,PSZCHN,ST,ST0,PSODTCT
+3 NEW SORT,TERM,CNT,ZZZ
+4 KILL ^UTILITY($JOB)
+5 ;IHS/ITSC/LJF 1/14/2004 varialbe needed by Phr v7
NEW HDR
SET HDR="ISSUE DATE"
+6 SET (FN,DA,D0)=DFN
SET PSRT="DATE"
SET X=""
+7 SET X1=DT
SET X2=-365
DO C^%DTC
SET PSODTCT=X
+8 SET X="PSOP"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET PLS="S"
USE IO
DO P^PSOP
QUIT
+9 SET X="PSP"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET PLS=1
USE IO
DO P^PSP
+10 QUIT
+11 ;
AIU(DFN,DIV) ; EP; prints address/insurance update
+1 NEW SDATE,ORDER,SDCNT,SDSTART,SDSTOP,SDX,SDREP
+2 NEW BSDX,BSDY,BSDFORM
+3 NEW SORT,TERM,CNT
+4 ;set to prevent device closure in BSDAIU
SET BSDFORM=1
+5 ;last reg update
SET BSDX=$$GET1^DIQ(9000001,DFN,.03,"I")
+6 ;waiting days
SET BSDY=$$GET1^DIQ(9009020.2,$$DIV^BSDU,.08)
+7 ;IHS/ITSC/WAR 3/16/04 chg greater than/less than symbol
+8 ;I $$FMADD^XLFDT(BSDX,BSDY)<DT Q ;not time yet
+9 ;not time yet
IF $$FMADD^XLFDT(BSDX,BSDY)>DT
QUIT
+10 IF $Y>5
WRITE @IOF
+11 DO BEGIN^BSDAIU
+12 QUIT
+13 ;
APRO(SC,DFN,CLDT) ;EP; calls pharmacy to print action profile
+1 NEW SDATE,ORDER,SDCNT,SDSTART,SDSTOP,DIV,SDX,SDREP
+2 NEW FN,DA,D0,PLS,PSRT,PSLC,PSZCHN,ST,ST0,PSODTCT
+3 NEW BSDATT,BSDATTO,BSDATTC,BSDIOM
+4 NEW SORT,TERM,CNT,ZZZ
+5 ;
+6 ; set variables needed by pharmacy routine
+7 KILL ^TMP($JOB)
+8 SET CLINICX=$PIECE(^SC(+SC,0),U)
+9 SET PAGE=1
SET D1=CLDT
SET PSTYPE=1
+10 SET PSDAYS=90
SET X1=DT
SET X2=-PSDAYS
DO C^%DTC
SET (PSDATE,PSDAY)=X
+11 SET LINE=$$REPEAT^XLFSTR("-",132)
+12 ;S BSDATT=$P(^DG(40.8,1,"IHS"),U,16) ;6/28/2002 per Linda (LJF11)
+13 ;APRO terminal type;IHS/ANMC/LJF 6/26/2002
SET BSDATT=$$GET1^DIQ(9009020.2,+$$DIV^BSDU,.13,"I")
IF 'BSDATT
QUIT
+14 ;IHS/ITSC/LJF 1/2/2004 added $G
SET BSDATTO=$GET(^%ZIS(2,BSDATT,2))
+15 ;IHS/ITSC/LJF 1/2/2004 added $G
SET BSDATTC=$GET(^%ZIS(2,BSDATT,3))
+16 ;IHS/ITSC/WAR 7/22/03 added next line to identify which pharmacy in ^PS
+17 ;S PSOSITE=$O(^PS(59,"C",DUZ(2),0))
+18 ;ihs/cmi/maw 03/01/2012 notified by Chris Saddler that this is now "D" for the station number
SET PSOSITE=$ORDER(^PS(59,"D",DUZ(2),0))
+19 XECUTE BSDATTO
SET BSDIOM=IOM
SET X=132
XECUTE ^%ZOSF("RM")
+20 DO HD^PSOSD2
DO PAT^PSOSD
IF PSTYPE
DO RXPAD^PSOSD1
+21 IF '$GET(PSTYPE)&('$DATA(^TMP("PSOD",$JOB)))
WRITE @IOF
+22 DO ENSTUFF^PSODACT
+23 XECUTE BSDATTC
SET X=BSDIOM
XECUTE ^%ZOSF("RM")
+24 KILL CLINICX,PAGE,PSTYPE,PSDAYS,PSDATE,PSDAY,PSDT,PSNAME
+25 KILL VAPA,VAIN,VAEL,VAERR,PSOBAR2,PSOBAR3,PSOBAR4,PSOPRINT,PSSN,RXCNT
+26 KILL LN,LINE,HRCN,FN,ELN,CNT,ADDRFL,VA,PSDOB
+27 QUIT
