VENPCC2A ; IHS/OIT/GIS - HEALTH SUMMARY GENERATOR ;
;;2.6;PCC+;;NOV 12, 2007
;
; VER 2.2 HS GENERATOR
; SUPPORTS OUTPUT FOR NEW PRINT SERVICE
;
HS(APCHSPAT,APCHSTYP,VISIT,DEPTIEN) ; EP-GENERATE A HEALTH SUMMARY
N PATH2,PATH3
I $D(^AUPNPAT(+$G(APCHSPAT),0)),$D(^APCHSCTL(+$G(APCHSTYP),0)),$D(^VEN(7.95,+$G(DEPTIEN),0))
E Q
I '$L($T(EN1^APCHS)) N ERR S ERR="Missing APCHS/APCHS0 patches. Can't print health summary!" D ERR^VENPCC1(ERR) Q
S %=$G(^VEN(7.5,+$G(CFIGIEN),2)) I %="" D ERR7^VENPCC1 Q
S PATH2=%,%=$G(^VEN(7.5,+$G(CFIGIEN),3)) I %="" D ERR7^VENPCC1 Q
S PATH3=%
NEW NEW %,%FN,%I,%T,%Y,APCHSFNM,APCHSIC,APCHSICD,APCHSICL,APCHSIR,APCHSNRQ,APCHSPDN,APCHSSGY,APCHSMTY,APCHSTAT,ARRAY,FILE,HEAD,I,POP,STOP,TAB,TMP,X,Y,APCHSERR,APCHSBWR
S TMP="^TMP(""VEN HS"",$J)",FILE="T"_VISIT_".TXT" K @TMP
S IOST="P-PRINTER",IOSL=99999,IOM=80
D DEL^VENPCCP1(PATH3,FILE) ; CLEAN UP THE TMP FILE ; PATCHED BY GIS 2/20/07
S POP=$$OPN^VENPCCP(PATH3,FILE,"W","N IO S IO=DEV D EN1^APCHS") K ^TMP($J,"APCHSMED") I POP Q
S POP=$$OPN^VENPCCP(PATH3,FILE,"R","D LINE^VENPCC2A") I POP Q
D DEL^VENPCCP1(PATH3,FILE) ; CLEAN UP THE TMP FILE AGAIN
PASS ; FIRST PASS THROUGH THE ARRAY
NEW %,I,PATIENT,SCNT,SNO,STOP,X
S SCNT=0
S %=$G(@TMP@(0,2)) I '$L(%) S ERR="Unable to generate health summary. Directory may be full!" D ERR^VENPCC1(ERR) Q ; /usr directory or descendent is full
S %=$P(%,"** ",2),%=$P(%," **") S @TMP@(2,"H1")=%
S %=$P(@TMP@(0,3),"** ",2),@TMP@(2,"H2")=" "_$P(%,"pg")
S @TMP@(2,"HEADER")="HS",@TMP@(2,"TEMPLATE")="HS2",@TMP@(2,"PRINTER")=""
S (%,PATIENT)=$P($G(^DPT(APCHSPAT,0)),U) I '$L(%) D ERR3^VENPCC1 S STOP=1 Q
S X=$P(%,",",2,99)_" "_$P(%,",")
I $G(DFN),$G(DEPTIEN) S X=X_" #"_$$CHART^VENPCC1A(DEPTIEN,DFN)
S @TMP@(2,"FOOTER")=X
S I=0 F S I=$O(@TMP@(0,I)) Q:'I S X=^(I) D
. I X["** END" K @TMP@(0,I-1),^(I),^(I+1)
. I X[("**"_$E(PATIENT,1,20)) K @TMP@(0,I) Q
. I X["CONFIDENTIAL PATIENT" K @TMP@(0,I) Q
. I $L(X)>50,$E(X)="-",$E(X,$L(X))="-" S %=$$STRIP^VENPCCU(X) S @TMP@(1,I)=% K @TMP@(0,I-1),^(I+1)
. Q
S SNO=0 F S SNO=$O(@TMP@(1,SNO)) Q:'SNO D SEC(SNO) I $G(STOP) Q
D EXP
K @TMP
D AUDIT(APCHSPAT,DUZ,$G(DEPTIEN),$G(VISIT))
Q
;
LINE F I=1:1 R X:30 Q:$$STATUS^%ZISH!(X["** END ") S @TMP@(0,I)=X
Q
;
SEC(SNO) ; EP-PROCESS A SECTION
NEW %,COMP,INO,NAME,REF,X,Y,LINE,LNO,STOP
S NAME=@TMP@(1,SNO),COMP=$P(NAME," (")
S SCNT=SCNT+1,STOP=0
SEC1 S @TMP@(2,("S"_SCNT))=NAME,INO=0,LNO=SNO
F S LNO=$O(@TMP@(0,LNO)) Q:'LNO S LINE=^(LNO) D I STOP Q
. I $E(LINE)="-",$E(LINE,$L(LINE))="-" S STOP=1 Q ; QUIT WHEN YOU REACH THE START OF NEXT SECTION
. D SET($C(9)_LINE) ; ATTACH A VALUE TO A FIELD. ALL FIELDS MUST START WITH A TAB CHARACTER
. Q
D SET($C(9))
Q
;
SET(X) ; EP-SAVE TMP GLOBALS
I X[U S X=$TR(X,U,"")
S INO=INO+1
I INO=44,SCNT=10 S @TMP@(2,"S1044")="",INO=45 ; FIXES PRINT SERVICE PROBLEM
; I INO>50 S:INO=51 @TMP@(2,("S"_(SCNT*100+50)))="<<Space constraints prevent display of additional lines in this section!!!>>" Q
S @TMP@(2,("S"_(SCNT*100+INO)))=X
I INO=50 S SCNT=SCNT+1,INO=0 ; OVERLAP INTO THE NEXT SECTION
Q
;
EXP ; EP-EXPORT THE MAIL MERGE FILE
I $P($G(^VEN(7.5,CFIGIEN,13)),U) D Q ; IN VER 2.5, GO DIRECTLY DATA FILE BUILDER
. N VER25,HSFLAG
. S VER25=1 S HSFLAG=1
. D TCP^VENPCC1 Q
. Q
; TRADITIONAL HS EXPORT...
NEW %,%FN,FILE,I,LINE,LNO,NAME,X,Y,Z,PATH
S @TMP@(3,1)="HEADER",^(2)="TEMPLATE",^(3)="GROUP",^(4)="PRINTER",^(5)="H1",^(6)="H2"
S I=6 F X=1:1:25 F Y=1:1:50 D
. I Y=1 S I=I+1,@TMP@(3,I)="S"_X,Z=X*100
. S I=I+1,@TMP@(3,I)="S"_(Z+Y)
. Q
S @TMP@(3,I+1)="FOOTER"
N HSFLAG S HSFLAG=1
D TCP^VENPCC1 ; TCP PRINT SERVICE
Q
;
AUDIT(PAT,USER,SITE,VISIT) ; EP-UPDATE AUDIT FILE
NEW %,%DT,%I,%Q,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y,DLAYGO
D NOW^%DTC S X=%
S DIC="^VEN(7.8,",DIC(0)="L",DLAYGO=19707.8 D ^DIC
I Y=-1 Q
S DIE=DIC,DA=+Y
S DR=".02////^ S X=$G(PAT);.03////^S X=$G(SITE);.04////^S X=USER"
I '$G(VFLAG),$L($G(VISIT)),'$G(NOVISIT) S DR=DR_";.05////^S X=VISIT"
I $G(APPDATE) S DR=DR_";.06////^S X=APPDATE"
L +^VEN(7.8):0 I $T D ^DIE L -^VEN(7.8)
Q
;
VENPCC2A ; IHS/OIT/GIS - HEALTH SUMMARY GENERATOR ;
+1 ;;2.6;PCC+;;NOV 12, 2007
+2 ;
+3 ; VER 2.2 HS GENERATOR
+4 ; SUPPORTS OUTPUT FOR NEW PRINT SERVICE
+5 ;
HS(APCHSPAT,APCHSTYP,VISIT,DEPTIEN) ; EP-GENERATE A HEALTH SUMMARY
+1 NEW PATH2,PATH3
+2 IF $DATA(^AUPNPAT(+$GET(APCHSPAT),0))
IF $DATA(^APCHSCTL(+$GET(APCHSTYP),0))
IF $DATA(^VEN(7.95,+$GET(DEPTIEN),0))
+3 IF '$TEST
QUIT
+4 IF '$LENGTH($TEXT(EN1^APCHS))
NEW ERR
SET ERR="Missing APCHS/APCHS0 patches. Can't print health summary!"
DO ERR^VENPCC1(ERR)
QUIT
+5 SET %=$GET(^VEN(7.5,+$GET(CFIGIEN),2))
IF %=""
DO ERR7^VENPCC1
QUIT
+6 SET PATH2=%
SET %=$GET(^VEN(7.5,+$GET(CFIGIEN),3))
IF %=""
DO ERR7^VENPCC1
QUIT
+7 SET PATH3=%
NEW NEW %,%FN,%I,%T,%Y,APCHSFNM,APCHSIC,APCHSICD,APCHSICL,APCHSIR,APCHSNRQ,APCHSPDN,APCHSSGY,APCHSMTY,APCHSTAT,ARRAY,FILE,HEAD,I,POP,STOP,TAB,TMP,X,Y,APCHSERR,APCHSBWR
+1 SET TMP="^TMP(""VEN HS"",$J)"
SET FILE="T"_VISIT_".TXT"
KILL @TMP
+2 SET IOST="P-PRINTER"
SET IOSL=99999
SET IOM=80
+3 ; CLEAN UP THE TMP FILE ; PATCHED BY GIS 2/20/07
DO DEL^VENPCCP1(PATH3,FILE)
+4 SET POP=$$OPN^VENPCCP(PATH3,FILE,"W","N IO S IO=DEV D EN1^APCHS")
KILL ^TMP($JOB,"APCHSMED")
IF POP
QUIT
+5 SET POP=$$OPN^VENPCCP(PATH3,FILE,"R","D LINE^VENPCC2A")
IF POP
QUIT
+6 ; CLEAN UP THE TMP FILE AGAIN
DO DEL^VENPCCP1(PATH3,FILE)
PASS ; FIRST PASS THROUGH THE ARRAY
+1 NEW %,I,PATIENT,SCNT,SNO,STOP,X
+2 SET SCNT=0
+3 ; /usr directory or descendent is full
SET %=$GET(@TMP@(0,2))
IF '$LENGTH(%)
SET ERR="Unable to generate health summary. Directory may be full!"
DO ERR^VENPCC1(ERR)
QUIT
+4 SET %=$PIECE(%,"** ",2)
SET %=$PIECE(%," **")
SET @TMP@(2,"H1")=%
+5 SET %=$PIECE(@TMP@(0,3),"** ",2)
SET @TMP@(2,"H2")=" "_$PIECE(%,"pg")
+6 SET @TMP@(2,"HEADER")="HS"
SET @TMP@(2,"TEMPLATE")="HS2"
SET @TMP@(2,"PRINTER")=""
+7 SET (%,PATIENT)=$PIECE($GET(^DPT(APCHSPAT,0)),U)
IF '$LENGTH(%)
DO ERR3^VENPCC1
SET STOP=1
QUIT
+8 SET X=$PIECE(%,",",2,99)_" "_$PIECE(%,",")
+9 IF $GET(DFN)
IF $GET(DEPTIEN)
SET X=X_" #"_$$CHART^VENPCC1A(DEPTIEN,DFN)
+10 SET @TMP@(2,"FOOTER")=X
+11 SET I=0
FOR
SET I=$ORDER(@TMP@(0,I))
IF 'I
QUIT
SET X=^(I)
Begin DoDot:1
+12 IF X["** END"
KILL @TMP@(0,I-1),^(I),^(I+1)
+13 IF X[("**"_$EXTRACT(PATIENT,1,20))
KILL @TMP@(0,I)
QUIT
+14 IF X["CONFIDENTIAL PATIENT"
KILL @TMP@(0,I)
QUIT
+15 IF $LENGTH(X)>50
IF $EXTRACT(X)="-"
IF $EXTRACT(X,$LENGTH(X))="-"
SET %=$$STRIP^VENPCCU(X)
SET @TMP@(1,I)=%
KILL @TMP@(0,I-1),^(I+1)
+16 QUIT
End DoDot:1
+17 SET SNO=0
FOR
SET SNO=$ORDER(@TMP@(1,SNO))
IF 'SNO
QUIT
DO SEC(SNO)
IF $GET(STOP)
QUIT
+18 DO EXP
+19 KILL @TMP
+20 DO AUDIT(APCHSPAT,DUZ,$GET(DEPTIEN),$GET(VISIT))
+21 QUIT
+22 ;
LINE FOR I=1:1
READ X:30
IF $$STATUS^%ZISH!(X["** END ")
QUIT
SET @TMP@(0,I)=X
+1 QUIT
+2 ;
SEC(SNO) ; EP-PROCESS A SECTION
+1 NEW %,COMP,INO,NAME,REF,X,Y,LINE,LNO,STOP
+2 SET NAME=@TMP@(1,SNO)
SET COMP=$PIECE(NAME," (")
+3 SET SCNT=SCNT+1
SET STOP=0
SEC1 SET @TMP@(2,("S"_SCNT))=NAME
SET INO=0
SET LNO=SNO
+1 FOR
SET LNO=$ORDER(@TMP@(0,LNO))
IF 'LNO
QUIT
SET LINE=^(LNO)
Begin DoDot:1
+2 ; QUIT WHEN YOU REACH THE START OF NEXT SECTION
IF $EXTRACT(LINE)="-"
IF $EXTRACT(LINE,$LENGTH(LINE))="-"
SET STOP=1
QUIT
+3 ; ATTACH A VALUE TO A FIELD. ALL FIELDS MUST START WITH A TAB CHARACTER
DO SET($CHAR(9)_LINE)
+4 QUIT
End DoDot:1
IF STOP
QUIT
+5 DO SET($CHAR(9))
+6 QUIT
+7 ;
SET(X) ; EP-SAVE TMP GLOBALS
+1 IF X[U
SET X=$TRANSLATE(X,U,"")
+2 SET INO=INO+1
+3 ; FIXES PRINT SERVICE PROBLEM
IF INO=44
IF SCNT=10
SET @TMP@(2,"S1044")=""
SET INO=45
+4 ; I INO>50 S:INO=51 @TMP@(2,("S"_(SCNT*100+50)))="<<Space constraints prevent display of additional lines in this section!!!>>" Q
+5 SET @TMP@(2,("S"_(SCNT*100+INO)))=X
+6 ; OVERLAP INTO THE NEXT SECTION
IF INO=50
SET SCNT=SCNT+1
SET INO=0
+7 QUIT
+8 ;
EXP ; EP-EXPORT THE MAIL MERGE FILE
+1 ; IN VER 2.5, GO DIRECTLY DATA FILE BUILDER
IF $PIECE($GET(^VEN(7.5,CFIGIEN,13)),U)
Begin DoDot:1
+2 NEW VER25,HSFLAG
+3 SET VER25=1
SET HSFLAG=1
+4 DO TCP^VENPCC1
QUIT
+5 QUIT
End DoDot:1
QUIT
+6 ; TRADITIONAL HS EXPORT...
+7 NEW %,%FN,FILE,I,LINE,LNO,NAME,X,Y,Z,PATH
+8 SET @TMP@(3,1)="HEADER"
SET ^(2)="TEMPLATE"
SET ^(3)="GROUP"
SET ^(4)="PRINTER"
SET ^(5)="H1"
SET ^(6)="H2"
+9 SET I=6
FOR X=1:1:25
FOR Y=1:1:50
Begin DoDot:1
+10 IF Y=1
SET I=I+1
SET @TMP@(3,I)="S"_X
SET Z=X*100
+11 SET I=I+1
SET @TMP@(3,I)="S"_(Z+Y)
+12 QUIT
End DoDot:1
+13 SET @TMP@(3,I+1)="FOOTER"
+14 NEW HSFLAG
SET HSFLAG=1
+15 ; TCP PRINT SERVICE
DO TCP^VENPCC1
+16 QUIT
+17 ;
AUDIT(PAT,USER,SITE,VISIT) ; EP-UPDATE AUDIT FILE
+1 NEW %,%DT,%I,%Q,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y,DLAYGO
+2 DO NOW^%DTC
SET X=%
+3 SET DIC="^VEN(7.8,"
SET DIC(0)="L"
SET DLAYGO=19707.8
DO ^DIC
+4 IF Y=-1
QUIT
+5 SET DIE=DIC
SET DA=+Y
+6 SET DR=".02////^ S X=$G(PAT);.03////^S X=$G(SITE);.04////^S X=USER"
+7 IF '$GET(VFLAG)
IF $LENGTH($GET(VISIT))
IF '$GET(NOVISIT)
SET DR=DR_";.05////^S X=VISIT"
+8 IF $GET(APPDATE)
SET DR=DR_";.06////^S X=APPDATE"
+9 LOCK +^VEN(7.8):0
IF $TEST
DO ^DIE
LOCK -^VEN(7.8)
+10 QUIT
+11 ;
