- DGPTFM5 ;ALB/MTK/ADL/PLT - PTF ENTRY/EDIT-3 ;11 MAR 91 15:15
- ;;5.3;Registration;**510,606,850,884,1057**;Aug 13, 1993;Build 17
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;;ADL;Update for CSV Project;;Mar 26, 2003
- ;
- S DGZS0=DGZS0+1
- EN D MOB:'$D(S) S S(DGZS0,1)=$S($D(S(DGZS0,1)):S(DGZS0,1),1:"") G NEXM:S(DGZS0,1)="" S (S1,S(DGZS0))=$S($D(^DGPT(PTF,"S",S(DGZS0,1),0)):^DGPT(PTF,"S",S(DGZS0,1),0),1:"")
- WR ;
- N EFFDATE,IMPDATE
- D EFFDATE^DGPTIC10(PTF)
- W @IOF,HEAD,?72 S Z="<401-"_DGZS0_">" D Z^DGPTFM
- W !,?30,"Initial Date Of Service: ",$$EXTERNAL^DILFD(45,14,,$G(DGIDTS)) ; DG*5.3*1057
- S L=+S(DGZS0),Y=L D D^DGPTUTL W !! S Z=1 D Z W "Date of Surg: " S Z=Y,Z1=28 D Z1 W "Chief Surg: ",$$EXTERNAL^DILFD(45.01,4,,$P(S1,U,4))
- W !," Anesth Tech: ",$$EXTERNAL^DILFD(45.01,6,,$P(S1,U,6)),?45,"First Asst: ",$$EXTERNAL^DILFD(45.01,5,,$P(S1,U,5))
- W !," Source of pay: ",$$EXTERNAL^DILFD(45.01,7,,$P(S1,U,7))
- W ?46,"Surg spec: ",$E($S($D(^DIC(45.3,+$P(S1,U,3),0)):$P(^(0),U,2),1:""),1,23)
- W !! S Z=2 D Z W " Surg/pro: ",$$GETLABEL^DGPTIC10(EFFDATE,"P") ;,!?7
- ;F I=1:1:5 S L=$P(S1,U,I+7) I L'="" D
- D PTFICD^DGPTFUT(401,PTF,S(DGZS0,1),.DGX401)
- S I=0 F S I=$O(DGX401(I)) QUIT:'I S L=+DGX401(I) D
- . S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE)
- . D WRITECOD^DGPTIC10("PROC",+L,EFFDATE,2,1,7) W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
- . I $Y>(IOSL-4) D PGBR W @IOF,HEAD,?72 N Z S Z="<401-"_DGZS0_">" D Z^DGPTFM W !
- . QUIT
- K DGX401
- ;-- kidney transplant source
- S DG300=$S($D(^DGPT(PTF,"S",S(DGZS0,1),300)):^(300),1:"") D:DG300]"" PRN3^DGPTFM8 K DG300
- W !!
- JUMP F I=$Y:1:19 W !
- X S DGNUM=$S($D(S(DGZS0+1)):401_"-"_(DGZS0+1),1:"MAS") G 401^DGPTFJC:DGST
- W "Enter <RET> to continue, 1-2 to edit,",!,"'S' to add a Surgical segment, '^N' for screen N, or '^' to abort:<",DGNUM,">// " R X:DTIME K DGNUM G Q:X="^",NEXM:X="",^DGPTFJ:X?1"^".E,ADD:X="S"!(X="s")
- X1 I X'=1,X'=2,X'="1-2" G PR
- X2 S DGCODSYS=$$CODESYS^DGPTIC10(PTF),DR=$S(DGCODSYS="ICD10":"[DG401-10P]",1:"[DG401]"),DGJUMP=X,DGSUR=+S(DGZS0,1)
- N ICDVDT,ICPTVDT,EFFDATE,IMPDATE
- D EFFDATE^DGPTIC10(PTF)
- ;S (ICDVDT,ICPTVDT)=$S($D(PTF):$$GETDATE^ICDGTDRG(PTF),1:DT)
- S (ICDVDT,ICPTVDT)=$S($G(EFFDATE)'="":EFFDATE,$D(PTF):$$GETDATE^ICDGTDRG(PTF),1:DT)
- K DA S DIE="^DGPT(",(DGPTF,DA)=PTF D ^DIE K DA,DR,DA
- D CHK401^DGPTSCAN K DGPTF,DGSUR D MOB G EN
- PR W !,"Enter '^' to stop the display and edit of data",!,"'^N' to jump to screen #N (appears in upper right of screen '<N>'",!,"<RET> to continue on to the next screen or 1-2 to edit:"
- W !?10,"1-Surgical information",!?10,"2-Surgical/Procedure Codes"
- W !,"You may also enter any combination of the above, separated by commas(ex:1,3,5)",!
- R !!,"Enter <RET>: ",X:DTIME G WR
- Q
- NEXM S DGZS0=DGZS0+1 G ^DGPTFM:'$D(S(DGZS0)) G EN
- ;
- ADD ;add 401 surgery record
- K SUR S DGZS0=0 S:'$D(^DGPT(PTF,"S",0)) ^(0)="^45.01DA^^"
- S DIC="^DGPT("_PTF_",""S"",",DIC(0)="QEALM",DA(1)=PTF D ^DIC G ^DGPTFM:+Y'>0!('$D(^DGPT(PTF,"S",+Y)))
- D MOB I SU F I=1:1:SU S:S(I,1)=+Y DGZS0=I
- G ^DGPTFM:'DGZS0 S SUR(DGZS0)=+Y,X="1,2" G X2
- MOB K S,S1,S2 S I=0,S2=0 F I1=1:1 S I=$O(^DGPT(PTF,"S",I)) Q:'I S S(I1)=^(I,0),S(I1,1)=I I S(I1)']"" K S(I1) S I1=I1-1
- S SU=I1-1 Q
- Q G Q^DGPTF
- Q
- 1 ;;.01;2;3;4;5;6;7
- 2 ;;8;9;10;11;12
- Q
- Z I 'DGN S Z=$S(IOST="C-QUME"&($L(DGVI)'=2):Z,1:"["_Z_"]") W @DGVI,Z,@DGVO
- E W " "
- Q
- Z1 F I=1:1:(Z1-$L(Z)) S Z=Z_" "
- W Z
- Q
- ;
- PGBR N DIR,X,Y S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR QUIT
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFM5 3523 printed Feb 19, 2025@00:18:25 Page 2
- DGPTFM5 ;ALB/MTK/ADL/PLT - PTF ENTRY/EDIT-3 ;11 MAR 91 15:15
- +1 ;;5.3;Registration;**510,606,850,884,1057**;Aug 13, 1993;Build 17
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;;ADL;Update for CSV Project;;Mar 26, 2003
- +5 ;
- +6 SET DGZS0=DGZS0+1
- EN if '$DATA(S)
- DO MOB
- SET S(DGZS0,1)=$SELECT($DATA(S(DGZS0,1)):S(DGZS0,1),1:"")
- if S(DGZS0,1)=""
- GOTO NEXM
- SET (S1,S(DGZS0))=$SELECT($DATA(^DGPT(PTF,"S",S(DGZS0,1),0)):^DGPT(PTF,"S",S(DGZS0,1),0),1:"")
- WR ;
- +1 NEW EFFDATE,IMPDATE
- +2 DO EFFDATE^DGPTIC10(PTF)
- +3 WRITE @IOF,HEAD,?72
- SET Z="<401-"_DGZS0_">"
- DO Z^DGPTFM
- +4 ; DG*5.3*1057
- WRITE !,?30,"Initial Date Of Service: ",$$EXTERNAL^DILFD(45,14,,$GET(DGIDTS))
- +5 SET L=+S(DGZS0)
- SET Y=L
- DO D^DGPTUTL
- WRITE !!
- SET Z=1
- DO Z
- WRITE "Date of Surg: "
- SET Z=Y
- SET Z1=28
- DO Z1
- WRITE "Chief Surg: ",$$EXTERNAL^DILFD(45.01,4,,$PIECE(S1,U,4))
- +6 WRITE !," Anesth Tech: ",$$EXTERNAL^DILFD(45.01,6,,$PIECE(S1,U,6)),?45,"First Asst: ",$$EXTERNAL^DILFD(45.01,5,,$PIECE(S1,U,5))
- +7 WRITE !," Source of pay: ",$$EXTERNAL^DILFD(45.01,7,,$PIECE(S1,U,7))
- +8 WRITE ?46,"Surg spec: ",$EXTRACT($SELECT($DATA(^DIC(45.3,+$PIECE(S1,U,3),0)):$PIECE(^(0),U,2),1:""),1,23)
- +9 ;,!?7
- WRITE !!
- SET Z=2
- DO Z
- WRITE " Surg/pro: ",$$GETLABEL^DGPTIC10(EFFDATE,"P")
- +10 ;F I=1:1:5 S L=$P(S1,U,I+7) I L'="" D
- +11 DO PTFICD^DGPTFUT(401,PTF,S(DGZS0,1),.DGX401)
- +12 SET I=0
- FOR
- SET I=$ORDER(DGX401(I))
- if 'I
- QUIT
- SET L=+DGX401(I)
- Begin DoDot:1
- +13 SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE)
- +14 DO WRITECOD^DGPTIC10("PROC",+L,EFFDATE,2,1,7)
- WRITE $SELECT(+DGPTTMP<1!('$PIECE(DGPTTMP,U,10)):"*",1:"")
- +15 IF $Y>(IOSL-4)
- DO PGBR
- WRITE @IOF,HEAD,?72
- NEW Z
- SET Z="<401-"_DGZS0_">"
- DO Z^DGPTFM
- WRITE !
- +16 QUIT
- End DoDot:1
- +17 KILL DGX401
- +18 ;-- kidney transplant source
- +19 SET DG300=$SELECT($DATA(^DGPT(PTF,"S",S(DGZS0,1),300)):^(300),1:"")
- if DG300]""
- DO PRN3^DGPTFM8
- KILL DG300
- +20 WRITE !!
- JUMP FOR I=$Y:1:19
- WRITE !
- X SET DGNUM=$SELECT($DATA(S(DGZS0+1)):401_"-"_(DGZS0+1),1:"MAS")
- if DGST
- GOTO 401^DGPTFJC
- +1 WRITE "Enter <RET> to continue, 1-2 to edit,",!,"'S' to add a Surgical segment, '^N' for screen N, or '^' to abort:<",DGNUM,">// "
- READ X:DTIME
- KILL DGNUM
- if X="^"
- GOTO Q
- if X=""
- GOTO NEXM
- if X?1"^".E
- GOTO ^DGPTFJ
- if X="S"!(X="s")
- GOTO ADD
- X1 IF X'=1
- IF X'=2
- IF X'="1-2"
- GOTO PR
- X2 SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)
- SET DR=$SELECT(DGCODSYS="ICD10":"[DG401-10P]",1:"[DG401]")
- SET DGJUMP=X
- SET DGSUR=+S(DGZS0,1)
- +1 NEW ICDVDT,ICPTVDT,EFFDATE,IMPDATE
- +2 DO EFFDATE^DGPTIC10(PTF)
- +3 ;S (ICDVDT,ICPTVDT)=$S($D(PTF):$$GETDATE^ICDGTDRG(PTF),1:DT)
- +4 SET (ICDVDT,ICPTVDT)=$SELECT($GET(EFFDATE)'="":EFFDATE,$DATA(PTF):$$GETDATE^ICDGTDRG(PTF),1:DT)
- +5 KILL DA
- SET DIE="^DGPT("
- SET (DGPTF,DA)=PTF
- DO ^DIE
- KILL DA,DR,DA
- +6 DO CHK401^DGPTSCAN
- KILL DGPTF,DGSUR
- DO MOB
- GOTO EN
- PR WRITE !,"Enter '^' to stop the display and edit of data",!,"'^N' to jump to screen #N (appears in upper right of screen '<N>'",!,"<RET> to continue on to the next screen or 1-2 to edit:"
- +1 WRITE !?10,"1-Surgical information",!?10,"2-Surgical/Procedure Codes"
- +2 WRITE !,"You may also enter any combination of the above, separated by commas(ex:1,3,5)",!
- +3 READ !!,"Enter <RET>: ",X:DTIME
- GOTO WR
- +4 QUIT
- NEXM SET DGZS0=DGZS0+1
- if '$DATA(S(DGZS0))
- GOTO ^DGPTFM
- GOTO EN
- +1 ;
- ADD ;add 401 surgery record
- +1 KILL SUR
- SET DGZS0=0
- if '$DATA(^DGPT(PTF,"S",0))
- SET ^(0)="^45.01DA^^"
- +2 SET DIC="^DGPT("_PTF_",""S"","
- SET DIC(0)="QEALM"
- SET DA(1)=PTF
- DO ^DIC
- if +Y'>0!('$DATA(^DGPT(PTF,"S",+Y)))
- GOTO ^DGPTFM
- +3 DO MOB
- IF SU
- FOR I=1:1:SU
- if S(I,1)=+Y
- SET DGZS0=I
- +4 if 'DGZS0
- GOTO ^DGPTFM
- SET SUR(DGZS0)=+Y
- SET X="1,2"
- GOTO X2
- MOB KILL S,S1,S2
- SET I=0
- SET S2=0
- FOR I1=1:1
- SET I=$ORDER(^DGPT(PTF,"S",I))
- if 'I
- QUIT
- SET S(I1)=^(I,0)
- SET S(I1,1)=I
- IF S(I1)']""
- KILL S(I1)
- SET I1=I1-1
- +1 SET SU=I1-1
- QUIT
- Q GOTO Q^DGPTF
- +1 QUIT
- 1 ;;.01;2;3;4;5;6;7
- 2 ;;8;9;10;11;12
- +1 QUIT
- Z IF 'DGN
- SET Z=$SELECT(IOST="C-QUME"&($LENGTH(DGVI)'=2):Z,1:"["_Z_"]")
- WRITE @DGVI,Z,@DGVO
- +1 IF '$TEST
- WRITE " "
- +2 QUIT
- Z1 FOR I=1:1:(Z1-$LENGTH(Z))
- SET Z=Z_" "
- +1 WRITE Z
- +2 QUIT
- +3 ;
- PGBR NEW DIR,X,Y
- SET DIR(0)="E"
- SET DIR("A")="Enter RETURN to continue"
- DO ^DIR
- QUIT
- +1 ;
