- DGANHD4 ;ALB/RMO - Print NHCU and DOM AMIS's 345-346 ; 01 SEP 90 10:47 am
- ;;5.3;Registration;;Aug 13, 1993
- ;==============================================================
- ;Print NHCU and DOM AMIS segment fields for each division.
- ;
- ;Input:
- ; DGMYR -Month/Year being printed in internal date format
- ; ^UTILITY-Contains stats by Month/Year, Segment and Division
- ;==============================================================
- S DGPGE=0,DGLNE="",DGIOM=$S('IOM:80,1:IOM),$P(DGLNE,"=",(DGIOM-1))="",DGX="",DGMAR=DGIOM-38
- F DGSEG=0:0 S DGSEG=$O(^UTILITY($J,"DGANHD",DGMYR,DGSEG)) Q:'DGSEG!(DGX["^") D SET,PRT
- ;
- Q K DGDIVNB,DGFLD,DGIOM,DGFLD,DGLNE,DGMAR,DGPGE,DGSEG,DGTAB,DGX,I,X,Y
- Q
- ;
- SET ;Set Tab Variable for Print
- K DGFLD S DGDIVNB=0 F I=0:0 S I=$O(^UTILITY($J,"DGANHD",DGMYR,DGSEG,I)) Q:'I S DGDIVNB=DGDIVNB+1
- S DGTAB=$S(DGMAR\DGDIVNB>20:20,1:DGMAR\DGDIVNB)
- Q
- ;
- PRT ;Print AMIS Segment
- D HD Q:DGX["^"
- S DGFLD="001^ADMIS AFTER REHOSP >30 DAYS" D FLD Q:DGX["^"
- S DGFLD="002^ADMISSIONS - ALL OTHER" D FLD Q:DGX["^"
- S DGFLD="003^TRANSFERS IN SIMAL FACIL" D FLD Q:DGX["^"
- S DGFLD="004^FROM ASIH" D FLD Q:DGX["^"
- S DGFLD="005^DISCHARGES" D FLD Q:DGX["^"
- S DGFLD="006^DEATHS,BO AND ABO" D FLD Q:DGX["^"
- S DGFLD="007^TRANSFERS OUT-SIMILAR FACIL" D FLD Q:DGX["^"
- S DGFLD="008^TO ASIH" D FLD Q:DGX["^"
- S DGFLD="009^BED OCCUPANTS EOM" D FLD Q:DGX["^"
- S DGFLD="010^ABSENT BED OCCUPANTS EOM" D FLD Q:DGX["^"
- S DGFLD="011^ASIH" D FLD Q:DGX["^"
- S DGFLD="012^FEMALE PATIENTS REMAINING EOM" D FLD Q:DGX["^"
- S DGFLD="013^DISCHARGES-ASIH" D FLD Q:DGX["^"
- S DGFLD="014^DIED-ASIH" D FLD Q:DGX["^"
- S DGFLD="015^PATIENT DAYS OF CARE" D FLD Q:DGX["^"
- S DGFLD="016^DAYS OF AUTH ABS <96 HRS" D FLD Q:DGX["^"
- S DGFLD="017^OPERATING BEDS EOM" D FLD Q:DGX["^"
- D LEG
- Q
- ;
- FLD ;Print Field for AMIS Segment
- D HD:($Y+7)>IOSL Q:DGX["^" W !,"(",$P(DGFLD,"^"),") ",$P(DGFLD,"^",2),?38
- F I=0:0 S I=$O(^UTILITY($J,"DGANHD",DGMYR,DGSEG,I)) Q:'I W $J(+$P(^(I),"^",+DGFLD),DGTAB-2)
- Q
- ;
- HD D CRCHK Q:DGX["^" W @IOF,!?30,"AMIS ",DGSEG," REPORT" S DGPGE=DGPGE+1 S Y=DT X ^DD("DD") W ?60,"DATE: ",Y
- W !?30,$S(DGSEG=345:"NURSING HOME",DGSEG=346:"DOMICILIARY",1:"UNKNOWN")
- S Y=DGMYR X ^DD("DD") W !?32,"for ",Y
- W !!?38 F I=0:0 S I=$O(^UTILITY($J,"DGANHD",DGMYR,DGSEG,I)) Q:'I W $J($E($S($D(^DG(40.8,I,0)):$P(^(0),"^"),1:"UNKNOWN"),1,DGTAB-2),DGTAB)
- W !,DGLNE
- Q
- ;
- LEG D CRCHK:($Y+7)>IOSL Q:DGX["^" W !,DGLNE,!,"FOR THIS SEGMENT FIELDS SHOULD BALANCE AS FOLLOWS:"
- W !!,?3,"Fields 009 and 010 prior period plus 001,002,003,004 current period"
- W !,?3,"less fields 005 thru 008 current period must equal fields",!?3,"009 and 010 current period."
- I $D(^DGAM(345,DGMYR,"SE",DGSEG,0)),'$P(^(0),"^",2) W !!,"*** This segment ",$S($P(^(0),"^",2)="":"has Not been Balanced",1:"is Out of Balance"),". ***"
- W !,DGLNE
- Q
- ;
- CRCHK I DGPGE,$E(IOST,1)="C" W !!,*7,"Press RETURN to continue or '^' to stop " R X:DTIME S:'$T X="^" S DGX=X
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGANHD4 2999 printed Feb 19, 2025@00:07:30 Page 2
- DGANHD4 ;ALB/RMO - Print NHCU and DOM AMIS's 345-346 ; 01 SEP 90 10:47 am
- +1 ;;5.3;Registration;;Aug 13, 1993
- +2 ;==============================================================
- +3 ;Print NHCU and DOM AMIS segment fields for each division.
- +4 ;
- +5 ;Input:
- +6 ; DGMYR -Month/Year being printed in internal date format
- +7 ; ^UTILITY-Contains stats by Month/Year, Segment and Division
- +8 ;==============================================================
- +9 SET DGPGE=0
- SET DGLNE=""
- SET DGIOM=$SELECT('IOM:80,1:IOM)
- SET $PIECE(DGLNE,"=",(DGIOM-1))=""
- SET DGX=""
- SET DGMAR=DGIOM-38
- +10 FOR DGSEG=0:0
- SET DGSEG=$ORDER(^UTILITY($JOB,"DGANHD",DGMYR,DGSEG))
- if 'DGSEG!(DGX["^")
- QUIT
- DO SET
- DO PRT
- +11 ;
- Q KILL DGDIVNB,DGFLD,DGIOM,DGFLD,DGLNE,DGMAR,DGPGE,DGSEG,DGTAB,DGX,I,X,Y
- +1 QUIT
- +2 ;
- SET ;Set Tab Variable for Print
- +1 KILL DGFLD
- SET DGDIVNB=0
- FOR I=0:0
- SET I=$ORDER(^UTILITY($JOB,"DGANHD",DGMYR,DGSEG,I))
- if 'I
- QUIT
- SET DGDIVNB=DGDIVNB+1
- +2 SET DGTAB=$SELECT(DGMAR\DGDIVNB>20:20,1:DGMAR\DGDIVNB)
- +3 QUIT
- +4 ;
- PRT ;Print AMIS Segment
- +1 DO HD
- if DGX["^"
- QUIT
- +2 SET DGFLD="001^ADMIS AFTER REHOSP >30 DAYS"
- DO FLD
- if DGX["^"
- QUIT
- +3 SET DGFLD="002^ADMISSIONS - ALL OTHER"
- DO FLD
- if DGX["^"
- QUIT
- +4 SET DGFLD="003^TRANSFERS IN SIMAL FACIL"
- DO FLD
- if DGX["^"
- QUIT
- +5 SET DGFLD="004^FROM ASIH"
- DO FLD
- if DGX["^"
- QUIT
- +6 SET DGFLD="005^DISCHARGES"
- DO FLD
- if DGX["^"
- QUIT
- +7 SET DGFLD="006^DEATHS,BO AND ABO"
- DO FLD
- if DGX["^"
- QUIT
- +8 SET DGFLD="007^TRANSFERS OUT-SIMILAR FACIL"
- DO FLD
- if DGX["^"
- QUIT
- +9 SET DGFLD="008^TO ASIH"
- DO FLD
- if DGX["^"
- QUIT
- +10 SET DGFLD="009^BED OCCUPANTS EOM"
- DO FLD
- if DGX["^"
- QUIT
- +11 SET DGFLD="010^ABSENT BED OCCUPANTS EOM"
- DO FLD
- if DGX["^"
- QUIT
- +12 SET DGFLD="011^ASIH"
- DO FLD
- if DGX["^"
- QUIT
- +13 SET DGFLD="012^FEMALE PATIENTS REMAINING EOM"
- DO FLD
- if DGX["^"
- QUIT
- +14 SET DGFLD="013^DISCHARGES-ASIH"
- DO FLD
- if DGX["^"
- QUIT
- +15 SET DGFLD="014^DIED-ASIH"
- DO FLD
- if DGX["^"
- QUIT
- +16 SET DGFLD="015^PATIENT DAYS OF CARE"
- DO FLD
- if DGX["^"
- QUIT
- +17 SET DGFLD="016^DAYS OF AUTH ABS <96 HRS"
- DO FLD
- if DGX["^"
- QUIT
- +18 SET DGFLD="017^OPERATING BEDS EOM"
- DO FLD
- if DGX["^"
- QUIT
- +19 DO LEG
- +20 QUIT
- +21 ;
- FLD ;Print Field for AMIS Segment
- +1 if ($Y+7)>IOSL
- DO HD
- if DGX["^"
- QUIT
- WRITE !,"(",$PIECE(DGFLD,"^"),") ",$PIECE(DGFLD,"^",2),?38
- +2 FOR I=0:0
- SET I=$ORDER(^UTILITY($JOB,"DGANHD",DGMYR,DGSEG,I))
- if 'I
- QUIT
- WRITE $JUSTIFY(+$PIECE(^(I),"^",+DGFLD),DGTAB-2)
- +3 QUIT
- +4 ;
- HD DO CRCHK
- if DGX["^"
- QUIT
- WRITE @IOF,!?30,"AMIS ",DGSEG," REPORT"
- SET DGPGE=DGPGE+1
- SET Y=DT
- XECUTE ^DD("DD")
- WRITE ?60,"DATE: ",Y
- +1 WRITE !?30,$SELECT(DGSEG=345:"NURSING HOME",DGSEG=346:"DOMICILIARY",1:"UNKNOWN")
- +2 SET Y=DGMYR
- XECUTE ^DD("DD")
- WRITE !?32,"for ",Y
- +3 WRITE !!?38
- FOR I=0:0
- SET I=$ORDER(^UTILITY($JOB,"DGANHD",DGMYR,DGSEG,I))
- if 'I
- QUIT
- WRITE $JUSTIFY($EXTRACT($SELECT($DATA(^DG(40.8,I,0)):$PIECE(^(0),"^"),1:"UNKNOWN"),1,DGTAB-2),DGTAB)
- +4 WRITE !,DGLNE
- +5 QUIT
- +6 ;
- LEG if ($Y+7)>IOSL
- DO CRCHK
- if DGX["^"
- QUIT
- WRITE !,DGLNE,!,"FOR THIS SEGMENT FIELDS SHOULD BALANCE AS FOLLOWS:"
- +1 WRITE !!,?3,"Fields 009 and 010 prior period plus 001,002,003,004 current period"
- +2 WRITE !,?3,"less fields 005 thru 008 current period must equal fields",!?3,"009 and 010 current period."
- +3 IF $DATA(^DGAM(345,DGMYR,"SE",DGSEG,0))
- IF '$PIECE(^(0),"^",2)
- WRITE !!,"*** This segment ",$SELECT($PIECE(^(0),"^",2)="":"has Not been Balanced",1:"is Out of Balance"),". ***"
- +4 WRITE !,DGLNE
- +5 QUIT
- +6 ;
- CRCHK IF DGPGE
- IF $EXTRACT(IOST,1)="C"
- WRITE !!,*7,"Press RETURN to continue or '^' to stop "
- READ X:DTIME
- if '$TEST
- SET X="^"
- SET DGX=X
- +1 QUIT