DVBHQAT ;ISC-ALbany/JLU HINQ packing routine [ 09/21/94 1:23 PM ]
;;4.0;HINQ;**22,32,36,49**;03/25/92
;
KIL K J,LF,D,K,N,T,Y0,Z1,LP,L2,L3,DVBLEN,DVBIO,DVBNUM,F1,F2,X1,G,I,T1,DVBTIME,Z,L,DVBDEV,DVBDSCH,DVBECHO,DVBEND,DVBLOG,DVBPRGM,DVBTIM,DVBTMX,DVBXM,DVBZ,DVBABORT,DVBVDI,DVBTSK,DVBCN,DVBP,DVBSN,DFN,DIC,X,Y,R,DVBDXSC,DVBIXMZ,DVBUSER,DVBCS
K DVBI,DVBFUE,DVBFUF,DVBBAS,DVBBIR,DVBINC,DVBP,DVBV1
K DVBID,DVBIDCU,DVBPU,DVBPW,DVBS,DVBV2,LP2,LX,LY,NXL,SPN
K DVBTRY,DVBRTC,DVBNRT
Q
;
HP W !!," Input from the 'P'atient File only requires you to select a Patient Name.",!," 'D'irect input will prompt for Social Security Number, Claim Number or Service Number.",!," You may enter Patients not in the Patient file."
W !," Direct input will not enter Patients in the Patient File."
Q
;
E S DVB12=1
F A=0:0 S A=$O(X(A)) Q:'A D S
K X
Q:'$D(XY(1))
F A=0:0 S A=$O(XY(A)) Q:'A S X(A)=XY(A) K XY(A)
;
EX K DVB12,A,XY,B,L
Q
;
S I $L(X(A))=245 S XY(DVB12)=X(A),DVB12=DVB12+1 K X(A) Q
I $L(X(A))<245 D S1 Q
I $L(X(A))>245 D S2 Q
Q
;
S1 S XY(DVB12)=X(A) K X(A) F B=0:0 S B=$O(X(B)) Q:'B S L=245-$L(XY(DVB12)),XY(DVB12)=XY(DVB12)_$E(X(B),1,L),X(B)=$E(X(B),L+1,999) K:'$L(X(B)) X(B) I $L(XY(DVB12))=245 S DVB12=DVB12+1 Q
Q
;
S2 F B=0:0 S XY(DVB12)=$E(X(A),1,245),X(A)=$E(X(A),246,999),DVB12=DVB12+1 I $L(X(A))<245 S A=0 Q
Q
;
CNLKUP S CN=$S($D(^DPT(DFN,.31)):$P(^(.31),"^",3),1:"")
I 'CN Q
I CN["P" S CN="" Q
S CN=$E(" 00000000",1,9-$L(CN))_CN
S DVBZ=$E(DVBZ,1,$L(DVBZ)-8)_"CN"_CN_$E(DVBZ,$L(DVBZ)-7,99)
S CN=$F(DVBZ,"/CN",24) Q
;
STUFF Q:'DFN
S DVBNOWRT="",DVBZSAV=DVBZ,DVBZ=$E(DVBZ,1,$L(DVBZ)-4)
D DIV^DVBHQZ4,EN1^DVBHQUT
S DVBZ=DVBZSAV K DVBZSAV Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHQAT 1713 printed Oct 16, 2024@17:59:22 Page 2
DVBHQAT ;ISC-ALbany/JLU HINQ packing routine [ 09/21/94 1:23 PM ]
+1 ;;4.0;HINQ;**22,32,36,49**;03/25/92
+2 ;
KIL KILL J,LF,D,K,N,T,Y0,Z1,LP,L2,L3,DVBLEN,DVBIO,DVBNUM,F1,F2,X1,G,I,T1,DVBTIME,Z,L,DVBDEV,DVBDSCH,DVBECHO,DVBEND,DVBLOG,DVBPRGM,DVBTIM,DVBTMX,DVBXM,DVBZ,DVBABORT,DVBVDI,DVBTSK,DVBCN,DVBP,DVBSN,DFN,DIC,X,Y,R,DVBDXSC,DVBIXMZ,DVBUSER,DVBCS
+1 KILL DVBI,DVBFUE,DVBFUF,DVBBAS,DVBBIR,DVBINC,DVBP,DVBV1
+2 KILL DVBID,DVBIDCU,DVBPU,DVBPW,DVBS,DVBV2,LP2,LX,LY,NXL,SPN
+3 KILL DVBTRY,DVBRTC,DVBNRT
+4 QUIT
+5 ;
HP WRITE !!," Input from the 'P'atient File only requires you to select a Patient Name.",!," 'D'irect input will prompt for Social Security Number, Claim Number or Service Number.",!," You may enter Patients not in the Patient file."
+1 WRITE !," Direct input will not enter Patients in the Patient File."
+2 QUIT
+3 ;
E SET DVB12=1
+1 FOR A=0:0
SET A=$ORDER(X(A))
if 'A
QUIT
DO S
+2 KILL X
+3 if '$DATA(XY(1))
QUIT
+4 FOR A=0:0
SET A=$ORDER(XY(A))
if 'A
QUIT
SET X(A)=XY(A)
KILL XY(A)
+5 ;
EX KILL DVB12,A,XY,B,L
+1 QUIT
+2 ;
S IF $LENGTH(X(A))=245
SET XY(DVB12)=X(A)
SET DVB12=DVB12+1
KILL X(A)
QUIT
+1 IF $LENGTH(X(A))<245
DO S1
QUIT
+2 IF $LENGTH(X(A))>245
DO S2
QUIT
+3 QUIT
+4 ;
S1 SET XY(DVB12)=X(A)
KILL X(A)
FOR B=0:0
SET B=$ORDER(X(B))
if 'B
QUIT
SET L=245-$LENGTH(XY(DVB12))
SET XY(DVB12)=XY(DVB12)_$EXTRACT(X(B),1,L)
SET X(B)=$EXTRACT(X(B),L+1,999)
if '$LENGTH(X(B))
KILL X(B)
IF $LENGTH(XY(DVB12))=245
SET DVB12=DVB12+1
QUIT
+1 QUIT
+2 ;
S2 FOR B=0:0
SET XY(DVB12)=$EXTRACT(X(A),1,245)
SET X(A)=$EXTRACT(X(A),246,999)
SET DVB12=DVB12+1
IF $LENGTH(X(A))<245
SET A=0
QUIT
+1 QUIT
+2 ;
CNLKUP SET CN=$SELECT($DATA(^DPT(DFN,.31)):$PIECE(^(.31),"^",3),1:"")
+1 IF 'CN
QUIT
+2 IF CN["P"
SET CN=""
QUIT
+3 SET CN=$EXTRACT(" 00000000",1,9-$LENGTH(CN))_CN
+4 SET DVBZ=$EXTRACT(DVBZ,1,$LENGTH(DVBZ)-8)_"CN"_CN_$EXTRACT(DVBZ,$LENGTH(DVBZ)-7,99)
+5 SET CN=$FIND(DVBZ,"/CN",24)
QUIT
+6 ;
STUFF if 'DFN
QUIT
+1 SET DVBNOWRT=""
SET DVBZSAV=DVBZ
SET DVBZ=$EXTRACT(DVBZ,1,$LENGTH(DVBZ)-4)
+2 DO DIV^DVBHQZ4
DO EN1^DVBHQUT
+3 SET DVBZ=DVBZSAV
KILL DVBZSAV
QUIT
