- DGMTHL ;ALB/CJM,SCG,TMK - Hardship Determinations - List Manager Screen; 1/02/2002
- ;;5.3;Registration;**182,344,435,467,536**;08/13/93;Build 3
- ;
- HARDSHIP ;Entry point for hardships
- ; Input -- None
- ; Output -- None
- N DFN,DGSITE,MTIEN,SGHRD,DGOK,DGDUZ
- ;
- ;Get Patient file (#2) IEN - DFN
- D GETPAT^DGRPTU(,,.DFN,) G ENQ:DFN<0
- N DGMDOD S DGMDOD=""
- I $P($G(^DPT(DFN,.35)),U)'="" S DGMDOD=$P(^DPT(DFN,.35),U)
- I $G(DGMDOD) W !,"Patient died on: ",$$FMTE^XLFDT(DGMDOD,"1D") Q
- ;
- S (MTIEN,SGHRD,DGSITE)="",DGOK=0
- S MTIEN=$$FIND^DGMTH(DFN,DT)
- S:MTIEN SGHRD=$P($G(^DGMT(408.31,MTIEN,2)),U,4)
- I SGHRD'="" D
- . S DGDUZ=$G(DUZ),DGDUZ(2)=$$CONVERT^DGENUPL1(SGHRD,"INSTITUTION")
- . S DGOK="",DGSITE=$$INST^DGENU(.DGDUZ,.DGOK)
- ;
- I SGHRD,$S(DGSITE=+$G(DUZ(2)):0,1:'DGOK) D Q
- .W !!?10,"A Hardship has been granted for ",$P(^DPT(DFN,0),U),"."
- .W !?10,"Only the site granting the Hardship may edit it."
- .W !?10,"Please, contact ",$P($G(^DIC(4,+$$CONVERT^DGENUPL1(SGHRD,"INSTITUTION"),0)),U)," to edit the record.",!
- .N DIR S DIR(0)="FAO",DIR("A")="Enter <RETURN> to continue." D ^DIR
- ;
- ;Load patient enrollment screen
- D EN(DFN)
- ENQ Q
- ;
- EN(DFN) ;Entry point for the DGMT HARDSHIP List Template
- ; Input -- DFN Patient IEN
- ; Output -- None
- ;
- Q:'$G(DFN)
- N HARDSHIP
- D WAIT^DICD
- D EN^VALM("DGMTH HARDSHIP")
- Q
- ;
- INIT ;Init variables and list array
- N MTIEN
- S MTIEN=$$FIND^DGMTH(DFN,DT)
- I $$GET^DGMTH(MTIEN,.HARDSHIP) ;setup hardship array
- D CLEAN^VALM10
- S VALMCNT=0
- D EN^DGMTHL1("DGMTH HARDSHIP",.HARDSHIP,.VALMCNT)
- Q
- ;
- HELP ;Help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ;Exit code
- D CLEAN^VALM10
- D CLEAR^VALM1
- Q
- ;
- EXPND ;Expand code
- Q
- ;
- HDR ;Header code
- N X,VA,VAERR
- D PID^VADPT
- S VALMHDR(1)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30)_" ("_VA("BID")_")"
- S X=$S('$D(^DPT(DFN,"TYPE")):"PATIENT TYPE UNKNOWN",$D(^DG(391,+^("TYPE"),0)):$P(^(0),U,1),1:"PATIENT TYPE UNKNOWN")
- S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),60,80)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGMTHL 2027 printed Jan 18, 2025@03:45:37 Page 2
- DGMTHL ;ALB/CJM,SCG,TMK - Hardship Determinations - List Manager Screen; 1/02/2002
- +1 ;;5.3;Registration;**182,344,435,467,536**;08/13/93;Build 3
- +2 ;
- HARDSHIP ;Entry point for hardships
- +1 ; Input -- None
- +2 ; Output -- None
- +3 NEW DFN,DGSITE,MTIEN,SGHRD,DGOK,DGDUZ
- +4 ;
- +5 ;Get Patient file (#2) IEN - DFN
- +6 DO GETPAT^DGRPTU(,,.DFN,)
- if DFN<0
- GOTO ENQ
- +7 NEW DGMDOD
- SET DGMDOD=""
- +8 IF $PIECE($GET(^DPT(DFN,.35)),U)'=""
- SET DGMDOD=$PIECE(^DPT(DFN,.35),U)
- +9 IF $GET(DGMDOD)
- WRITE !,"Patient died on: ",$$FMTE^XLFDT(DGMDOD,"1D")
- QUIT
- +10 ;
- +11 SET (MTIEN,SGHRD,DGSITE)=""
- SET DGOK=0
- +12 SET MTIEN=$$FIND^DGMTH(DFN,DT)
- +13 if MTIEN
- SET SGHRD=$PIECE($GET(^DGMT(408.31,MTIEN,2)),U,4)
- +14 IF SGHRD'=""
- Begin DoDot:1
- +15 SET DGDUZ=$GET(DUZ)
- SET DGDUZ(2)=$$CONVERT^DGENUPL1(SGHRD,"INSTITUTION")
- +16 SET DGOK=""
- SET DGSITE=$$INST^DGENU(.DGDUZ,.DGOK)
- End DoDot:1
- +17 ;
- +18 IF SGHRD
- IF $SELECT(DGSITE=+$GET(DUZ(2)):0,1:'DGOK)
- Begin DoDot:1
- +19 WRITE !!?10,"A Hardship has been granted for ",$PIECE(^DPT(DFN,0),U),"."
- +20 WRITE !?10,"Only the site granting the Hardship may edit it."
- +21 WRITE !?10,"Please, contact ",$PIECE($GET(^DIC(4,+$$CONVERT^DGENUPL1(SGHRD,"INSTITUTION"),0)),U)," to edit the record.",!
- +22 NEW DIR
- SET DIR(0)="FAO"
- SET DIR("A")="Enter <RETURN> to continue."
- DO ^DIR
- End DoDot:1
- QUIT
- +23 ;
- +24 ;Load patient enrollment screen
- +25 DO EN(DFN)
- ENQ QUIT
- +1 ;
- EN(DFN) ;Entry point for the DGMT HARDSHIP List Template
- +1 ; Input -- DFN Patient IEN
- +2 ; Output -- None
- +3 ;
- +4 if '$GET(DFN)
- QUIT
- +5 NEW HARDSHIP
- +6 DO WAIT^DICD
- +7 DO EN^VALM("DGMTH HARDSHIP")
- +8 QUIT
- +9 ;
- INIT ;Init variables and list array
- +1 NEW MTIEN
- +2 SET MTIEN=$$FIND^DGMTH(DFN,DT)
- +3 ;setup hardship array
- IF $$GET^DGMTH(MTIEN,.HARDSHIP)
- +4 DO CLEAN^VALM10
- +5 SET VALMCNT=0
- +6 DO EN^DGMTHL1("DGMTH HARDSHIP",.HARDSHIP,.VALMCNT)
- +7 QUIT
- +8 ;
- HELP ;Help code
- +1 SET X="?"
- DO DISP^XQORM1
- WRITE !!
- +2 QUIT
- +3 ;
- EXIT ;Exit code
- +1 DO CLEAN^VALM10
- +2 DO CLEAR^VALM1
- +3 QUIT
- +4 ;
- EXPND ;Expand code
- +1 QUIT
- +2 ;
- HDR ;Header code
- +1 NEW X,VA,VAERR
- +2 DO PID^VADPT
- +3 SET VALMHDR(1)=$EXTRACT("Patient: "_$PIECE($GET(^DPT(DFN,0)),U),1,30)_" ("_VA("BID")_")"
- +4 SET X=$SELECT('$DATA(^DPT(DFN,"TYPE")):"PATIENT TYPE UNKNOWN",$DATA(^DG(391,+^("TYPE"),0)):$PIECE(^(0),U,1),1:"PATIENT TYPE UNKNOWN")
- +5 SET VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),60,80)
- +6 QUIT