- 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 Feb 18, 2025@23:24:55 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
